From 69b6010f0016bba47bc7e74ad8e1f3fa473f259f Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 4 Apr 2013 11:07:59 +0200 Subject: [PATCH] Imported Upstream version 0.1 --- ASMPrinter.ml | 7 + ASMPrinter.mli | 4 + IntelHex.ml | 367 + IntelHex.mli | 7 + acc.ml | 85 + build | 15 + clightFromC.ml | 985 +++ clightParser.ml | 51 + clightParser.mli | 9 + clightPrinter.ml | 692 ++ clightPrinter.mli | 23 + error.ml | 94 + extracted/MODIFIED_BY_HAND | 3 + extracted/PROBLEMS | 17 + extracted/aSM.ml | 6090 +++++++++++++++++ extracted/aSM.mli | 1377 ++++ extracted/aSMCosts.ml | 763 +++ extracted/aSMCosts.mli | 152 + extracted/aSMCostsSplit.ml | 177 + extracted/aSMCostsSplit.mli | 132 + extracted/aST.ml | 1667 +++++ extracted/aST.mli | 698 ++ extracted/abstractStatus.ml | 197 + extracted/abstractStatus.mli | 133 + extracted/arithmetic.ml | 807 +++ extracted/arithmetic.mli | 310 + extracted/assembly.ml | 3275 +++++++++ extracted/assembly.mli | 181 + extracted/assocList.ml | 46 + extracted/assocList.mli | 34 + extracted/bEMem.ml | 98 + extracted/bEMem.mli | 92 + extracted/backEndOps.ml | 1225 ++++ extracted/backEndOps.mli | 320 + extracted/bigops.ml | 371 + extracted/bigops.mli | 225 + extracted/bindLists.ml | 87 + extracted/bindLists.mli | 68 + extracted/bind_new.ml | 162 + extracted/bind_new.mli | 94 + extracted/bitVector.ml | 110 + extracted/bitVector.mli | 77 + extracted/bitVectorTrie.ml | 322 + extracted/bitVectorTrie.mli | 135 + extracted/bitVectorTrieSet.ml | 120 + extracted/bitVectorTrieSet.mli | 65 + extracted/bitVectorZ.ml | 123 + extracted/bitVectorZ.mli | 65 + extracted/blocks.ml | 173 + extracted/blocks.mli | 152 + extracted/bool.ml | 102 + extracted/bool.mli | 48 + extracted/build | 7 + extracted/byteValues.ml | 1092 +++ extracted/byteValues.mli | 484 ++ extracted/casts.ml | 92 + extracted/casts.mli | 87 + extracted/cexec.ml | 1189 ++++ extracted/cexec.mli | 185 + extracted/cexecInd.ml | 76 + extracted/cexecInd.mli | 76 + extracted/cexecSound.ml | 120 + extracted/cexecSound.mli | 120 + extracted/classifyOp.ml | 885 +++ extracted/classifyOp.mli | 473 ++ extracted/clight_abstract.ml | 179 + extracted/clight_abstract.mli | 144 + extracted/clight_classified_system.ml | 151 + extracted/clight_classified_system.mli | 137 + extracted/cminor_abstract.ml | 180 + extracted/cminor_abstract.mli | 148 + extracted/cminor_classified_system.ml | 147 + extracted/cminor_classified_system.mli | 131 + extracted/cminor_semantics.ml | 929 +++ extracted/cminor_semantics.mli | 366 + extracted/cminor_syntax.ml | 892 +++ extracted/cminor_syntax.mli | 473 ++ extracted/compiler.ml | 756 ++ extracted/compiler.mli | 440 ++ extracted/coqlib.ml | 34 + extracted/coqlib.mli | 30 + extracted/core_notation.ml | 2 + extracted/core_notation.mli | 2 + extracted/costCheck.ml | 227 + extracted/costCheck.mli | 137 + extracted/costInj.ml | 147 + extracted/costInj.mli | 120 + extracted/costLabel.ml | 64 + extracted/costLabel.mli | 60 + extracted/costMisc.ml | 112 + extracted/costMisc.mli | 112 + extracted/costSpec.ml | 175 + extracted/costSpec.mli | 117 + extracted/csem.ml | 1264 ++++ extracted/csem.mli | 401 ++ extracted/csyntax.ml | 1640 +++++ extracted/csyntax.mli | 666 ++ extracted/deqsets.ml | 144 + extracted/deqsets.mli | 79 + extracted/deqsets_extra.ml | 41 + extracted/deqsets_extra.mli | 37 + extracted/div_and_mod.ml | 109 + extracted/div_and_mod.mli | 59 + extracted/division.ml | 251 + extracted/division.mli | 81 + extracted/eRTL.ml | 710 ++ extracted/eRTL.mli | 411 ++ extracted/eRTLToLTL.ml | 985 +++ extracted/eRTLToLTL.mli | 372 + extracted/eRTL_printer.ml | 133 + extracted/eRTL_printer.mli | 128 + extracted/eRTL_semantics.ml | 391 ++ extracted/eRTL_semantics.mli | 218 + extracted/errorMessages.ml | 84 + extracted/errorMessages.mli | 84 + extracted/errors.ml | 318 + extracted/errors.mli | 176 + extracted/events.ml | 379 + extracted/events.mli | 240 + extracted/executions.ml | 92 + extracted/executions.mli | 92 + extracted/exp.ml | 23 + extracted/exp.mli | 20 + extracted/extraGlobalenvs.ml | 96 + extracted/extraGlobalenvs.mli | 96 + extracted/extraMonads.ml | 310 + extracted/extraMonads.mli | 216 + extracted/extra_bool.ml | 35 + extracted/extra_bool.mli | 30 + extracted/extralib.ml | 74 + extracted/extralib.mli | 44 + extracted/extranat.ml | 180 + extracted/extranat.mli | 96 + extracted/fetch.ml | 1660 +++++ extracted/fetch.mli | 112 + extracted/fixpoints.ml | 322 + extracted/fixpoints.mli | 222 + extracted/foldStuff.ml | 66 + extracted/foldStuff.mli | 44 + extracted/fresh.ml | 121 + extracted/fresh.mli | 98 + extracted/frontEndMem.ml | 163 + extracted/frontEndMem.mli | 113 + extracted/frontEndOps.ml | 1353 ++++ extracted/frontEndOps.mli | 538 ++ extracted/frontEndVal.ml | 191 + extracted/frontEndVal.mli | 104 + extracted/frontend_misc.ml | 279 + extracted/frontend_misc.mli | 169 + extracted/genMem.ml | 346 + extracted/genMem.mli | 209 + extracted/globalenvs.ml | 737 ++ extracted/globalenvs.mli | 404 ++ extracted/graphs.ml | 93 + extracted/graphs.mli | 85 + extracted/hide.ml | 10 + extracted/hide.mli | 10 + extracted/hints_declaration.ml | 12 + extracted/hints_declaration.mli | 12 + extracted/i8051.ml | 777 +++ extracted/i8051.mli | 219 + extracted/i8051bis.ml | 35 + extracted/i8051bis.mli | 26 + extracted/iO.ml | 269 + extracted/iO.mli | 161 + extracted/iOMonad.ml | 556 ++ extracted/iOMonad.mli | 310 + extracted/identifiers.ml | 525 ++ extracted/identifiers.mli | 320 + extracted/initialisation.ml | 214 + extracted/initialisation.mli | 136 + extracted/integers.ml | 367 + extracted/integers.mli | 167 + extracted/interference.ml | 314 + extracted/interference.mli | 231 + extracted/interpret.ml | 4348 ++++++++++++ extracted/interpret.mli | 166 + extracted/interpret2.ml | 469 ++ extracted/interpret2.mli | 180 + extracted/jmeq.ml | 132 + extracted/jmeq.mli | 76 + extracted/joint.ml | 2740 ++++++++ extracted/joint.mli | 1518 ++++ extracted/joint_LTL_LIN.ml | 380 + extracted/joint_LTL_LIN.mli | 252 + extracted/joint_LTL_LIN_semantics.ml | 324 + extracted/joint_LTL_LIN_semantics.mli | 189 + extracted/joint_fullexec.ml | 212 + extracted/joint_fullexec.mli | 172 + extracted/joint_printer.ml | 1467 ++++ extracted/joint_printer.mli | 700 ++ extracted/joint_semantics.ml | 2603 +++++++ extracted/joint_semantics.mli | 1294 ++++ extracted/lIN.ml | 147 + extracted/lIN.mli | 128 + extracted/lINToASM.ml | 1447 ++++ extracted/lINToASM.mli | 356 + extracted/lIN_printer.ml | 135 + extracted/lIN_printer.mli | 130 + extracted/lIN_semantics.ml | 164 + extracted/lIN_semantics.mli | 158 + extracted/lTL.ml | 211 + extracted/lTL.mli | 158 + extracted/lTLToLIN.ml | 132 + extracted/lTLToLIN.mli | 130 + extracted/lTL_printer.ml | 135 + extracted/lTL_printer.mli | 130 + extracted/lTL_semantics.ml | 164 + extracted/lTL_semantics.mli | 158 + extracted/label.ml | 709 ++ extracted/label.mli | 146 + extracted/labelledObjects.ml | 104 + extracted/labelledObjects.mli | 78 + extracted/linearise.ml | 339 + extracted/linearise.mli | 159 + extracted/list.ml | 319 + extracted/list.mli | 159 + extracted/listb.ml | 55 + extracted/listb.mli | 35 + extracted/listb_extra.ml | 42 + extracted/listb_extra.mli | 42 + extracted/lists.ml | 100 + extracted/lists.mli | 58 + extracted/liveness.ml | 470 ++ extracted/liveness.mli | 186 + extracted/logic.ml | 249 + extracted/logic.mli | 128 + extracted/measurable.ml | 554 ++ extracted/measurable.mli | 299 + extracted/memProperties.ml | 138 + extracted/memProperties.mli | 130 + extracted/memoryInjections.ml | 242 + extracted/memoryInjections.mli | 191 + extracted/monad.ml | 549 ++ extracted/monad.mli | 334 + extracted/nat.ml | 134 + extracted/nat.mli | 61 + extracted/option.ml | 55 + extracted/option.mli | 36 + extracted/order.ml | 86 + extracted/order.mli | 46 + extracted/pointers.ml | 385 ++ extracted/pointers.mli | 225 + extracted/policy.ml | 193 + extracted/policy.mli | 106 + extracted/policyFront.ml | 689 ++ extracted/policyFront.mli | 147 + extracted/policyStep.ml | 211 + extracted/policyStep.mli | 93 + extracted/positive.ml | 410 ++ extracted/positive.mli | 158 + extracted/positiveMap.ml | 386 ++ extracted/positiveMap.mli | 146 + extracted/preIdentifiers.ml | 193 + extracted/preIdentifiers.mli | 107 + extracted/preamble.ml | 2 + extracted/proper.ml | 12 + extracted/proper.mli | 12 + extracted/pts.ml | 4 + extracted/pts.mli | 4 + extracted/rTL.ml | 325 + extracted/rTL.mli | 200 + extracted/rTLToERTL.ml | 512 ++ extracted/rTLToERTL.mli | 222 + extracted/rTL_printer.ml | 133 + extracted/rTL_printer.mli | 128 + extracted/rTL_semantics.ml | 795 +++ extracted/rTL_semantics.mli | 363 + extracted/rTLabsToRTL.ml | 1283 ++++ extracted/rTLabsToRTL.mli | 409 ++ extracted/rTLabs_abstract.ml | 615 ++ extracted/rTLabs_abstract.mli | 318 + extracted/rTLabs_classified_system.ml | 169 + extracted/rTLabs_classified_system.mli | 145 + extracted/rTLabs_semantics.ml | 1711 +++++ extracted/rTLabs_semantics.mli | 336 + extracted/rTLabs_syntax.ml | 653 ++ extracted/rTLabs_syntax.mli | 423 ++ extracted/rTLabs_traces.ml | 1902 +++++ extracted/rTLabs_traces.mli | 840 +++ extracted/registerSet.ml | 321 + extracted/registerSet.mli | 207 + extracted/registers.ml | 64 + extracted/registers.mli | 62 + extracted/relations.ml | 24 + extracted/relations.mli | 22 + extracted/russell.ml | 14 + extracted/russell.mli | 14 + extracted/semantics.ml | 469 ++ extracted/semantics.mli | 379 + extracted/semanticsUtils.ml | 767 +++ extracted/semanticsUtils.mli | 479 ++ extracted/setoids.ml | 86 + extracted/setoids.mli | 52 + extracted/sets.ml | 10 + extracted/sets.mli | 10 + extracted/simplifyCasts.ml | 722 ++ extracted/simplifyCasts.mli | 174 + extracted/smallstep.ml | 501 ++ extracted/smallstep.mli | 321 + extracted/smallstepExec.ml | 625 ++ extracted/smallstepExec.mli | 350 + extracted/stacksize.ml | 311 + extracted/stacksize.mli | 198 + extracted/star.ml | 12 + extracted/star.mli | 12 + extracted/state.ml | 58 + extracted/state.mli | 42 + extracted/status.ml | 4176 +++++++++++ extracted/status.mli | 561 ++ extracted/statusProofs.ml | 82 + extracted/statusProofs.mli | 82 + extracted/string.ml | 33 + extracted/string.mli | 21 + extracted/structuredTraces.ml | 1893 +++++ extracted/structuredTraces.mli | 979 +++ extracted/switchRemoval.ml | 577 ++ extracted/switchRemoval.mli | 278 + extracted/toCminor.ml | 2265 ++++++ extracted/toCminor.mli | 536 ++ extracted/toRTLabs.ml | 1409 ++++ extracted/toRTLabs.mli | 681 ++ extracted/traces.ml | 711 ++ extracted/traces.mli | 396 ++ extracted/translateUtils.ml | 710 ++ extracted/translateUtils.mli | 411 ++ extracted/typeComparison.ml | 289 + extracted/typeComparison.mli | 94 + extracted/types.ml | 435 ++ extracted/types.mli | 224 + extracted/untrusted/Fix.ml | 529 ++ extracted/untrusted/Fix.mli | 103 + extracted/untrusted/build.ml | 137 + extracted/untrusted/build.mli | 13 + extracted/untrusted/coloring.ml | 374 + extracted/untrusted/coloring.mli | 38 + extracted/untrusted/compute_colouring.ml | 65 + extracted/untrusted/compute_colouring.mli | 5 + extracted/untrusted/compute_fixpoints.ml | 35 + extracted/untrusted/compute_fixpoints.mli | 1 + extracted/untrusted/glue.ml | 41 + extracted/untrusted/glue.mli | 13 + extracted/untrusted/myMap.ml | 372 + extracted/untrusted/myMap.mli | 143 + extracted/untrusted/ocamlList.ml | 27 + extracted/untrusted/ocamlString.ml | 5 + extracted/untrusted/pmap.ml | 111 + extracted/untrusted/pmap.mli | 13 + extracted/untrusted/prioritySet.ml | 146 + extracted/untrusted/prioritySet.mli | 54 + extracted/untrusted/pset.ml | 197 + extracted/untrusted/pset.mli | 27 + extracted/untrusted/setMap.ml | 226 + extracted/untrusted/setMap.mli | 144 + extracted/untrusted/set_adt.ml | 31 + extracted/untrusted/set_adt.mli | 19 + extracted/untrusted/spill.ml | 159 + extracted/untrusted/spill.mli | 36 + extracted/untrusted/untrusted_interference.ml | 873 +++ .../untrusted/untrusted_interference.mli | 220 + extracted/uses.ml | 192 + extracted/uses.mli | 126 + extracted/util.ml | 667 ++ extracted/util.mli | 237 + extracted/utilBranch.ml | 51 + extracted/utilBranch.mli | 48 + extracted/values.ml | 528 ++ extracted/values.mli | 193 + extracted/vector.ml | 477 ++ extracted/vector.mli | 193 + extracted/z.ml | 306 + extracted/z.mli | 107 + options.ml | 188 + options.mli | 90 + optionsParsing.ml | 16 + printer.ml | 269 + printer.mli | 2 + rTLabsPrinter.ml | 338 + rTLabsPrinter.mli | 6 + tests/PROBLEMI | 9 + tests/bubble_sort.c | 41 + tests/test.c | 5 + tests/test2.c | 13 + tests/test3.c | 5 + tests/test4.c | 8 + tests/test5.c | 3 + tests/test6.c | 9 + tests/test7.c | 21 + tests/test8.c | 4 + 389 files changed, 130596 insertions(+) create mode 100644 ASMPrinter.ml create mode 100644 ASMPrinter.mli create mode 100644 IntelHex.ml create mode 100644 IntelHex.mli create mode 100644 acc.ml create mode 100755 build create mode 100644 clightFromC.ml create mode 100644 clightParser.ml create mode 100644 clightParser.mli create mode 100644 clightPrinter.ml create mode 100644 clightPrinter.mli create mode 100644 error.ml create mode 100644 extracted/MODIFIED_BY_HAND create mode 100644 extracted/PROBLEMS create mode 100644 extracted/aSM.ml create mode 100644 extracted/aSM.mli create mode 100644 extracted/aSMCosts.ml create mode 100644 extracted/aSMCosts.mli create mode 100644 extracted/aSMCostsSplit.ml create mode 100644 extracted/aSMCostsSplit.mli create mode 100644 extracted/aST.ml create mode 100644 extracted/aST.mli create mode 100644 extracted/abstractStatus.ml create mode 100644 extracted/abstractStatus.mli create mode 100644 extracted/arithmetic.ml create mode 100644 extracted/arithmetic.mli create mode 100644 extracted/assembly.ml create mode 100644 extracted/assembly.mli create mode 100644 extracted/assocList.ml create mode 100644 extracted/assocList.mli create mode 100644 extracted/bEMem.ml create mode 100644 extracted/bEMem.mli create mode 100644 extracted/backEndOps.ml create mode 100644 extracted/backEndOps.mli create mode 100644 extracted/bigops.ml create mode 100644 extracted/bigops.mli create mode 100644 extracted/bindLists.ml create mode 100644 extracted/bindLists.mli create mode 100644 extracted/bind_new.ml create mode 100644 extracted/bind_new.mli create mode 100644 extracted/bitVector.ml create mode 100644 extracted/bitVector.mli create mode 100644 extracted/bitVectorTrie.ml create mode 100644 extracted/bitVectorTrie.mli create mode 100644 extracted/bitVectorTrieSet.ml create mode 100644 extracted/bitVectorTrieSet.mli create mode 100644 extracted/bitVectorZ.ml create mode 100644 extracted/bitVectorZ.mli create mode 100644 extracted/blocks.ml create mode 100644 extracted/blocks.mli create mode 100644 extracted/bool.ml create mode 100644 extracted/bool.mli create mode 100755 extracted/build create mode 100644 extracted/byteValues.ml create mode 100644 extracted/byteValues.mli create mode 100644 extracted/casts.ml create mode 100644 extracted/casts.mli create mode 100644 extracted/cexec.ml create mode 100644 extracted/cexec.mli create mode 100644 extracted/cexecInd.ml create mode 100644 extracted/cexecInd.mli create mode 100644 extracted/cexecSound.ml create mode 100644 extracted/cexecSound.mli create mode 100644 extracted/classifyOp.ml create mode 100644 extracted/classifyOp.mli create mode 100644 extracted/clight_abstract.ml create mode 100644 extracted/clight_abstract.mli create mode 100644 extracted/clight_classified_system.ml create mode 100644 extracted/clight_classified_system.mli create mode 100644 extracted/cminor_abstract.ml create mode 100644 extracted/cminor_abstract.mli create mode 100644 extracted/cminor_classified_system.ml create mode 100644 extracted/cminor_classified_system.mli create mode 100644 extracted/cminor_semantics.ml create mode 100644 extracted/cminor_semantics.mli create mode 100644 extracted/cminor_syntax.ml create mode 100644 extracted/cminor_syntax.mli create mode 100644 extracted/compiler.ml create mode 100644 extracted/compiler.mli create mode 100644 extracted/coqlib.ml create mode 100644 extracted/coqlib.mli create mode 100644 extracted/core_notation.ml create mode 100644 extracted/core_notation.mli create mode 100644 extracted/costCheck.ml create mode 100644 extracted/costCheck.mli create mode 100644 extracted/costInj.ml create mode 100644 extracted/costInj.mli create mode 100644 extracted/costLabel.ml create mode 100644 extracted/costLabel.mli create mode 100644 extracted/costMisc.ml create mode 100644 extracted/costMisc.mli create mode 100644 extracted/costSpec.ml create mode 100644 extracted/costSpec.mli create mode 100644 extracted/csem.ml create mode 100644 extracted/csem.mli create mode 100644 extracted/csyntax.ml create mode 100644 extracted/csyntax.mli create mode 100644 extracted/deqsets.ml create mode 100644 extracted/deqsets.mli create mode 100644 extracted/deqsets_extra.ml create mode 100644 extracted/deqsets_extra.mli create mode 100644 extracted/div_and_mod.ml create mode 100644 extracted/div_and_mod.mli create mode 100644 extracted/division.ml create mode 100644 extracted/division.mli create mode 100644 extracted/eRTL.ml create mode 100644 extracted/eRTL.mli create mode 100644 extracted/eRTLToLTL.ml create mode 100644 extracted/eRTLToLTL.mli create mode 100644 extracted/eRTL_printer.ml create mode 100644 extracted/eRTL_printer.mli create mode 100644 extracted/eRTL_semantics.ml create mode 100644 extracted/eRTL_semantics.mli create mode 100644 extracted/errorMessages.ml create mode 100644 extracted/errorMessages.mli create mode 100644 extracted/errors.ml create mode 100644 extracted/errors.mli create mode 100644 extracted/events.ml create mode 100644 extracted/events.mli create mode 100644 extracted/executions.ml create mode 100644 extracted/executions.mli create mode 100644 extracted/exp.ml create mode 100644 extracted/exp.mli create mode 100644 extracted/extraGlobalenvs.ml create mode 100644 extracted/extraGlobalenvs.mli create mode 100644 extracted/extraMonads.ml create mode 100644 extracted/extraMonads.mli create mode 100644 extracted/extra_bool.ml create mode 100644 extracted/extra_bool.mli create mode 100644 extracted/extralib.ml create mode 100644 extracted/extralib.mli create mode 100644 extracted/extranat.ml create mode 100644 extracted/extranat.mli create mode 100644 extracted/fetch.ml create mode 100644 extracted/fetch.mli create mode 100644 extracted/fixpoints.ml create mode 100644 extracted/fixpoints.mli create mode 100644 extracted/foldStuff.ml create mode 100644 extracted/foldStuff.mli create mode 100644 extracted/fresh.ml create mode 100644 extracted/fresh.mli create mode 100644 extracted/frontEndMem.ml create mode 100644 extracted/frontEndMem.mli create mode 100644 extracted/frontEndOps.ml create mode 100644 extracted/frontEndOps.mli create mode 100644 extracted/frontEndVal.ml create mode 100644 extracted/frontEndVal.mli create mode 100644 extracted/frontend_misc.ml create mode 100644 extracted/frontend_misc.mli create mode 100644 extracted/genMem.ml create mode 100644 extracted/genMem.mli create mode 100644 extracted/globalenvs.ml create mode 100644 extracted/globalenvs.mli create mode 100644 extracted/graphs.ml create mode 100644 extracted/graphs.mli create mode 100644 extracted/hide.ml create mode 100644 extracted/hide.mli create mode 100644 extracted/hints_declaration.ml create mode 100644 extracted/hints_declaration.mli create mode 100644 extracted/i8051.ml create mode 100644 extracted/i8051.mli create mode 100644 extracted/i8051bis.ml create mode 100644 extracted/i8051bis.mli create mode 100644 extracted/iO.ml create mode 100644 extracted/iO.mli create mode 100644 extracted/iOMonad.ml create mode 100644 extracted/iOMonad.mli create mode 100644 extracted/identifiers.ml create mode 100644 extracted/identifiers.mli create mode 100644 extracted/initialisation.ml create mode 100644 extracted/initialisation.mli create mode 100644 extracted/integers.ml create mode 100644 extracted/integers.mli create mode 100644 extracted/interference.ml create mode 100644 extracted/interference.mli create mode 100644 extracted/interpret.ml create mode 100644 extracted/interpret.mli create mode 100644 extracted/interpret2.ml create mode 100644 extracted/interpret2.mli create mode 100644 extracted/jmeq.ml create mode 100644 extracted/jmeq.mli create mode 100644 extracted/joint.ml create mode 100644 extracted/joint.mli create mode 100644 extracted/joint_LTL_LIN.ml create mode 100644 extracted/joint_LTL_LIN.mli create mode 100644 extracted/joint_LTL_LIN_semantics.ml create mode 100644 extracted/joint_LTL_LIN_semantics.mli create mode 100644 extracted/joint_fullexec.ml create mode 100644 extracted/joint_fullexec.mli create mode 100644 extracted/joint_printer.ml create mode 100644 extracted/joint_printer.mli create mode 100644 extracted/joint_semantics.ml create mode 100644 extracted/joint_semantics.mli create mode 100644 extracted/lIN.ml create mode 100644 extracted/lIN.mli create mode 100644 extracted/lINToASM.ml create mode 100644 extracted/lINToASM.mli create mode 100644 extracted/lIN_printer.ml create mode 100644 extracted/lIN_printer.mli create mode 100644 extracted/lIN_semantics.ml create mode 100644 extracted/lIN_semantics.mli create mode 100644 extracted/lTL.ml create mode 100644 extracted/lTL.mli create mode 100644 extracted/lTLToLIN.ml create mode 100644 extracted/lTLToLIN.mli create mode 100644 extracted/lTL_printer.ml create mode 100644 extracted/lTL_printer.mli create mode 100644 extracted/lTL_semantics.ml create mode 100644 extracted/lTL_semantics.mli create mode 100644 extracted/label.ml create mode 100644 extracted/label.mli create mode 100644 extracted/labelledObjects.ml create mode 100644 extracted/labelledObjects.mli create mode 100644 extracted/linearise.ml create mode 100644 extracted/linearise.mli create mode 100644 extracted/list.ml create mode 100644 extracted/list.mli create mode 100644 extracted/listb.ml create mode 100644 extracted/listb.mli create mode 100644 extracted/listb_extra.ml create mode 100644 extracted/listb_extra.mli create mode 100644 extracted/lists.ml create mode 100644 extracted/lists.mli create mode 100644 extracted/liveness.ml create mode 100644 extracted/liveness.mli create mode 100644 extracted/logic.ml create mode 100644 extracted/logic.mli create mode 100644 extracted/measurable.ml create mode 100644 extracted/measurable.mli create mode 100644 extracted/memProperties.ml create mode 100644 extracted/memProperties.mli create mode 100644 extracted/memoryInjections.ml create mode 100644 extracted/memoryInjections.mli create mode 100644 extracted/monad.ml create mode 100644 extracted/monad.mli create mode 100644 extracted/nat.ml create mode 100644 extracted/nat.mli create mode 100644 extracted/option.ml create mode 100644 extracted/option.mli create mode 100644 extracted/order.ml create mode 100644 extracted/order.mli create mode 100644 extracted/pointers.ml create mode 100644 extracted/pointers.mli create mode 100644 extracted/policy.ml create mode 100644 extracted/policy.mli create mode 100644 extracted/policyFront.ml create mode 100644 extracted/policyFront.mli create mode 100644 extracted/policyStep.ml create mode 100644 extracted/policyStep.mli create mode 100644 extracted/positive.ml create mode 100644 extracted/positive.mli create mode 100644 extracted/positiveMap.ml create mode 100644 extracted/positiveMap.mli create mode 100644 extracted/preIdentifiers.ml create mode 100644 extracted/preIdentifiers.mli create mode 100644 extracted/preamble.ml create mode 100644 extracted/proper.ml create mode 100644 extracted/proper.mli create mode 100644 extracted/pts.ml create mode 100644 extracted/pts.mli create mode 100644 extracted/rTL.ml create mode 100644 extracted/rTL.mli create mode 100644 extracted/rTLToERTL.ml create mode 100644 extracted/rTLToERTL.mli create mode 100644 extracted/rTL_printer.ml create mode 100644 extracted/rTL_printer.mli create mode 100644 extracted/rTL_semantics.ml create mode 100644 extracted/rTL_semantics.mli create mode 100644 extracted/rTLabsToRTL.ml create mode 100644 extracted/rTLabsToRTL.mli create mode 100644 extracted/rTLabs_abstract.ml create mode 100644 extracted/rTLabs_abstract.mli create mode 100644 extracted/rTLabs_classified_system.ml create mode 100644 extracted/rTLabs_classified_system.mli create mode 100644 extracted/rTLabs_semantics.ml create mode 100644 extracted/rTLabs_semantics.mli create mode 100644 extracted/rTLabs_syntax.ml create mode 100644 extracted/rTLabs_syntax.mli create mode 100644 extracted/rTLabs_traces.ml create mode 100644 extracted/rTLabs_traces.mli create mode 100644 extracted/registerSet.ml create mode 100644 extracted/registerSet.mli create mode 100644 extracted/registers.ml create mode 100644 extracted/registers.mli create mode 100644 extracted/relations.ml create mode 100644 extracted/relations.mli create mode 100644 extracted/russell.ml create mode 100644 extracted/russell.mli create mode 100644 extracted/semantics.ml create mode 100644 extracted/semantics.mli create mode 100644 extracted/semanticsUtils.ml create mode 100644 extracted/semanticsUtils.mli create mode 100644 extracted/setoids.ml create mode 100644 extracted/setoids.mli create mode 100644 extracted/sets.ml create mode 100644 extracted/sets.mli create mode 100644 extracted/simplifyCasts.ml create mode 100644 extracted/simplifyCasts.mli create mode 100644 extracted/smallstep.ml create mode 100644 extracted/smallstep.mli create mode 100644 extracted/smallstepExec.ml create mode 100644 extracted/smallstepExec.mli create mode 100644 extracted/stacksize.ml create mode 100644 extracted/stacksize.mli create mode 100644 extracted/star.ml create mode 100644 extracted/star.mli create mode 100644 extracted/state.ml create mode 100644 extracted/state.mli create mode 100644 extracted/status.ml create mode 100644 extracted/status.mli create mode 100644 extracted/statusProofs.ml create mode 100644 extracted/statusProofs.mli create mode 100644 extracted/string.ml create mode 100644 extracted/string.mli create mode 100644 extracted/structuredTraces.ml create mode 100644 extracted/structuredTraces.mli create mode 100644 extracted/switchRemoval.ml create mode 100644 extracted/switchRemoval.mli create mode 100644 extracted/toCminor.ml create mode 100644 extracted/toCminor.mli create mode 100644 extracted/toRTLabs.ml create mode 100644 extracted/toRTLabs.mli create mode 100644 extracted/traces.ml create mode 100644 extracted/traces.mli create mode 100644 extracted/translateUtils.ml create mode 100644 extracted/translateUtils.mli create mode 100644 extracted/typeComparison.ml create mode 100644 extracted/typeComparison.mli create mode 100644 extracted/types.ml create mode 100644 extracted/types.mli create mode 100644 extracted/untrusted/Fix.ml create mode 100644 extracted/untrusted/Fix.mli create mode 100644 extracted/untrusted/build.ml create mode 100644 extracted/untrusted/build.mli create mode 100644 extracted/untrusted/coloring.ml create mode 100644 extracted/untrusted/coloring.mli create mode 100644 extracted/untrusted/compute_colouring.ml create mode 100644 extracted/untrusted/compute_colouring.mli create mode 100644 extracted/untrusted/compute_fixpoints.ml create mode 100644 extracted/untrusted/compute_fixpoints.mli create mode 100644 extracted/untrusted/glue.ml create mode 100644 extracted/untrusted/glue.mli create mode 100644 extracted/untrusted/myMap.ml create mode 100644 extracted/untrusted/myMap.mli create mode 100644 extracted/untrusted/ocamlList.ml create mode 100644 extracted/untrusted/ocamlString.ml create mode 100644 extracted/untrusted/pmap.ml create mode 100644 extracted/untrusted/pmap.mli create mode 100644 extracted/untrusted/prioritySet.ml create mode 100644 extracted/untrusted/prioritySet.mli create mode 100644 extracted/untrusted/pset.ml create mode 100644 extracted/untrusted/pset.mli create mode 100644 extracted/untrusted/setMap.ml create mode 100644 extracted/untrusted/setMap.mli create mode 100644 extracted/untrusted/set_adt.ml create mode 100644 extracted/untrusted/set_adt.mli create mode 100644 extracted/untrusted/spill.ml create mode 100644 extracted/untrusted/spill.mli create mode 100644 extracted/untrusted/untrusted_interference.ml create mode 100644 extracted/untrusted/untrusted_interference.mli create mode 100644 extracted/uses.ml create mode 100644 extracted/uses.mli create mode 100644 extracted/util.ml create mode 100644 extracted/util.mli create mode 100644 extracted/utilBranch.ml create mode 100644 extracted/utilBranch.mli create mode 100644 extracted/values.ml create mode 100644 extracted/values.mli create mode 100644 extracted/vector.ml create mode 100644 extracted/vector.mli create mode 100644 extracted/z.ml create mode 100644 extracted/z.mli create mode 100644 options.ml create mode 100644 options.mli create mode 100644 optionsParsing.ml create mode 100644 printer.ml create mode 100644 printer.mli create mode 100644 rTLabsPrinter.ml create mode 100644 rTLabsPrinter.mli create mode 100644 tests/PROBLEMI create mode 100644 tests/bubble_sort.c create mode 100644 tests/test.c create mode 100644 tests/test2.c create mode 100644 tests/test3.c create mode 100644 tests/test4.c create mode 100644 tests/test5.c create mode 100644 tests/test6.c create mode 100644 tests/test7.c create mode 100644 tests/test8.c diff --git a/ASMPrinter.ml b/ASMPrinter.ml new file mode 100644 index 0000000..7991649 --- /dev/null +++ b/ASMPrinter.ml @@ -0,0 +1,7 @@ + +(** This module provides a function to print [ASM] programs. *) + +let print_program p = + let intel_hex = + IntelHex.pack_exported_code_memory 16 65535 p.Extracted.ASM.cm in + IntelHex.string_of_intel_hex_format intel_hex diff --git a/ASMPrinter.mli b/ASMPrinter.mli new file mode 100644 index 0000000..415cada --- /dev/null +++ b/ASMPrinter.mli @@ -0,0 +1,4 @@ + +(** This module provides a function to print [ASM] programs. *) + +val print_program : Extracted.ASM.labelled_object_code -> string diff --git a/IntelHex.ml b/IntelHex.ml new file mode 100644 index 0000000..827b33e --- /dev/null +++ b/IntelHex.ml @@ -0,0 +1,367 @@ +(************* Glue code ******************************) + +let ($) f x = f x +let flip f a b = f b a + +type byte = Extracted.BitVector.byte +type word = Extracted.BitVector.word + +let size_lookup = function `Eight -> 8 | `Sixteen -> 16 + +let zero size = + let size = size_lookup size in + Extracted.BitVector.zero (Extracted.Glue.matitanat_of_int size) + +let int_of_vect v = + Extracted.Glue.int_of_matitanat (Extracted.Arithmetic.nat_of_bitvector (Extracted.Glue.matitanat_of_int 0 (* dummy *)) v);; + +(* CSC: can overflow!!! *) +(* CSC: only works properly with bytes!!! *) +let hex_string_of_vect v = Printf.sprintf "%0 2X" (int_of_vect v);; + +let complement v = Extracted.BitVector.negation_bv (Extracted.Glue.matitanat_of_int 8) v + +let divide_with_remainder x y = (x / y, x mod y) + +let rec nat_to_bv n k = + match n with + | Extracted.Nat.O -> Extracted.Vector.VEmpty + | Extracted.Nat.S n' -> + let res,modu = divide_with_remainder k 2 in + Extracted.Vector.VCons (n', + (if modu = 1 then Extracted.Bool.True else Extracted.Bool.False), + nat_to_bv n' res) + +let vect_of_int k n = + Extracted.Vector.reverse + (Extracted.Glue.matitanat_of_int (size_lookup n)) + (nat_to_bv (Extracted.Glue.matitanat_of_int (size_lookup n)) k) + +let from_word v = + let {Extracted.Types.fst = fst ; snd = snd} = + Extracted.Vector.vsplit (Extracted.Glue.matitanat_of_int 8) + (Extracted.Glue.matitanat_of_int 8) v in + fst,snd + +let half_add b1 b2 = + let {Extracted.Types.fst = fst ; snd = snd} = + Extracted.Arithmetic.half_add (Extracted.Glue.matitanat_of_int 8) b1 b2 in + fst = Extracted.Bool.True, snd + +module WordMap : + sig + val find : word -> Extracted.BitVector.byte Extracted.BitVectorTrie.bitVectorTrie -> byte + end = +struct + let find k m = Extracted.BitVectorTrie.lookup (Extracted.Glue.matitanat_of_int 16) k m (zero `Eight) +end;; + +(************* Untrusted code ******************************) +(* +open BitVectors;; +open ASM;; +open Util;; +open Parser;; +open Printf;; + +exception WrongFormat of string +*) + +type intel_hex_entry_type = + Data + | End + | ExtendedSeg + | ExtendedLinear +;; + +type intel_hex_entry = +{ + record_length: byte; + record_addr: word; + record_type: intel_hex_entry_type; + data_field: byte list; + data_checksum: byte +} +;; + +type intel_hex_format = intel_hex_entry list;; + +(* +let hex_digit_of_char = + function + '0' -> 0 | '1' -> 1 | '2' -> 2 + | '3' -> 3 | '4' -> 4 | '5' -> 5 + | '6' -> 6 | '7' -> 7 | '8' -> 8 + | '9' -> 9 | 'A' -> 10 | 'B' -> 11 + | 'C' -> 12 | 'D' -> 13 | 'E' -> 14 + | 'F' -> 15 | 'a' -> 10 | 'b' -> 11 + | 'c' -> 12 | 'd' -> 13 | 'e' -> 14 + | 'f' -> 15 | _ -> assert false + +let intel_hex_entry_type_of_int = + function + 0 -> Data + | 1 -> End + | 2 -> ExtendedSeg + | 4 -> ExtendedLinear + | _ -> assert false +;; +*) + +let int_of_intel_hex_entry_type = + function + Data -> 0 + | End -> 1 + | ExtendedSeg -> 2 + | ExtendedLinear -> 4 +;; + +(* +let prs_nibble = + prs_hex_digit >>= +fun a -> return $ vect_of_int (hex_digit_of_char a) `Four +;; + +let prs_byte = + prs_nibble >>= +fun a -> prs_nibble >>= +fun b -> return $ mk_byte a b +;; + +let prs_word = + prs_byte >>= +fun a -> prs_byte >>= +fun b -> return $ mk_word a b +;; + +let prs_length = prs_byte;; +let prs_data len = prs_exact len prs_byte +let prs_checksum = prs_byte;; +let prs_addr = prs_word;; + +let prs_type = + prs_hex_digit >>= +fun a -> prs_hex_digit >>= +fun b -> + let a_as_hex = hex_digit_of_char a in + let b_as_hex = hex_digit_of_char b in +(*CSC: is next line correct??? *) + let total = a_as_hex + b_as_hex in + return $ intel_hex_entry_type_of_int total +*) + +let add_bytes v = + let r = List.rev v in + let rec aux (cry, bs) = + function + [] -> (cry, bs) + | hd::tl -> + aux (half_add hd bs) tl + in + aux (false, (vect_of_int 0 `Eight)) r + +let calculate_checksum hex_entry = + let ty = (flip vect_of_int $ `Eight) $ int_of_intel_hex_entry_type hex_entry.record_type in + let addr1,addr2 = from_word hex_entry.record_addr in + let _, total = add_bytes (hex_entry.record_length :: addr1 :: addr2 :: ty :: hex_entry.data_field) in + let _,total = half_add (vect_of_int 1 `Eight) $ complement total in + total + +(* +let checksum_valid hex_entry = + let total = calculate_checksum hex_entry in + hex_entry.data_checksum = total + +let prs_intel_hex_record = + prs_char ':' >>= +fun _ -> prs_length >>= +fun b -> prs_addr >>= +fun c -> prs_type >>= +fun d -> prs_data (int_of_vect b) >>= +fun e -> prs_checksum >>= +fun f -> prs_eof >>= +fun _ -> + let entry = + { record_length = b; + record_addr = c; + record_type = d; + data_field = e; + data_checksum = f } + in + if checksum_valid entry then + return entry + else + prs_zero +;; + +let prs_intel_hex_format = + prs_sep_by prs_intel_hex_record (prs_char '\n') +;; + +let intel_hex_format_of_string s = + let chars = char_list_of_string s in + match prs_intel_hex_format chars with + [] -> None + | (prs,_)::_ -> Some prs +*) + +let string_of_intel_hex_entry entry = + let b = Buffer.create 655536 in + let length_string = hex_string_of_vect entry.record_length in + let addr_string = Printf.sprintf "%04X" (int_of_vect entry.record_addr) in + let checksum_string = Printf.sprintf "%02X" (int_of_vect entry.data_checksum) in + let type_string = Printf.sprintf "%02d" (int_of_intel_hex_entry_type entry.record_type) in + List.iter (Buffer.add_string b) + [ + ":"; length_string; addr_string; type_string + ]; + List.iter (fun e -> Buffer.add_string b (hex_string_of_vect e)) entry.data_field; + Buffer.add_string b checksum_string; + Buffer.contents b +;; + +let string_of_intel_hex_format f = + let strs = List.map string_of_intel_hex_entry f in + let rec aux = + function + [] -> "" + | [e] -> e + | hd::tl -> hd ^ "\n" ^ aux tl + in + aux strs + +(* +let intel_hex_of_file path = + let fd = open_in path in + let rec aux () = + match try Some (input_line fd) with End_of_file -> None with + None -> [] + | Some txt -> + let read = prs_intel_hex_record (Parser.chars_of_string txt) in + let read = + match read with + [x,[]] -> x + | _ -> raise (WrongFormat txt) + in + read::aux () + in + aux () +;; + +let rec load_from mem addr = + function + [] -> mem + | he::tl -> + load_from (Physical.WordMap.add addr he mem) (snd (BitVectors.half_add addr (BitVectors.vect_of_int 1 `Sixteen))) tl +;; + +let process_intel_hex = + let rec aux mem = + function + [] -> assert false + | he::tl -> + match he.record_type with + End -> assert (tl = []); mem + | Data -> aux (load_from mem he.record_addr he.data_field) tl + | _ -> assert false + in + aux Physical.WordMap.empty +;; +*) + +(* DPM: this needs some comment: + We aim to extract code memory into segmented lists of bytes, with a maximum + length (chunk_size). The code memory map has a fixed size (max_addressable) + on the 8051. Further, the chunks we extract get segmented when we find an + unitialized zone in the code memory. +*) +let export_code_memory chunk_size max_addressable code_mem = + let rec aux chunk address start_address rbuff lbuff = + if address = max_addressable then + (start_address, List.rev rbuff)::lbuff + else if chunk = 0 then + aux chunk_size address address [] ((start_address, List.rev rbuff)::lbuff) + else + let code = WordMap.find (vect_of_int address `Sixteen) code_mem in +(*prerr_string ("M(" ^ string_of_int address ^ "=" ^ string_of_int (int_of_vect (vect_of_int address `Sixteen)) ^ ")" ^ hex_string_of_vect code ^ " ");*) + aux (chunk - 1) (address + 1) start_address (code::rbuff) lbuff + in + List.rev (aux chunk_size 0 0 [] []) +;; + +let clean_exported_code_memory = List.filter (fun x -> snd x <> []) +;; + +(* +let calculate_data_checksum (record_length, record_addr, record_type, data_field) = + let ty = (flip vect_of_int $ `Eight) $ int_of_intel_hex_entry_type record_type in + let addr1,addr2 = from_word record_addr in + let _, total = add_bytes (record_length :: addr1 :: addr2 :: ty :: data_field) in + let _,total = half_add (vect_of_int 0 `Eight) $ complement total in + total +;; +*) + +let process_exported_code_memory = + List.map (fun x -> + let record_length = vect_of_int (List.length (snd x)) `Eight in + let record_addr = vect_of_int (fst x) `Sixteen in + let record_type = Data in + let data_field = snd x in + let temp_record = + { record_length = record_length; + record_addr = record_addr; + record_type = record_type; + data_field = data_field; + data_checksum = zero `Eight + } in + { temp_record with data_checksum = calculate_checksum temp_record }) +;; + +let rec zeros len = + if len = 0 then + [] + else + vect_of_int 0 `Eight :: zeros (len - 1) + +let post_process_exported_code_memory intel_hex = + let reversed = List.rev intel_hex in + let rec aux hex = + match hex with + [] -> [] + | he::tl -> + if he.record_type = End then + aux tl + else if he.record_type = Data then + if he.data_field = zeros (int_of_vect he.record_length) then + aux tl + else + he::(aux tl) + else + tl + in + List.rev (aux reversed) + +let pack_exported_code_memory chunk_size max_addressable code_mem = + let export = export_code_memory chunk_size max_addressable code_mem in + let cleaned = clean_exported_code_memory export in + let processed = process_exported_code_memory cleaned in + let postprocessed = post_process_exported_code_memory processed in + let end_buffer = + [{ record_length = zero `Eight; + record_addr = zero `Sixteen; + record_type = End; + data_field = []; + data_checksum = vect_of_int 255 `Eight + }] in + postprocessed @ end_buffer +;; + +(* +let file_of_intel_hex path fmt = + let str_fmt = string_of_intel_hex_format fmt in + let channel = open_out path in + fprintf channel "%s\n" str_fmt; + close_out channel +;; +*) diff --git a/IntelHex.mli b/IntelHex.mli new file mode 100644 index 0000000..0a05b77 --- /dev/null +++ b/IntelHex.mli @@ -0,0 +1,7 @@ +type intel_hex_format + +val int_of_vect : Extracted.BitVector.bitVector -> int + +val string_of_intel_hex_format: intel_hex_format -> string + +val pack_exported_code_memory: int -> int -> Extracted.BitVector.byte Extracted.BitVectorTrie.bitVectorTrie -> intel_hex_format diff --git a/acc.ml b/acc.ml new file mode 100644 index 0000000..40c5d5e --- /dev/null +++ b/acc.ml @@ -0,0 +1,85 @@ +open Extracted.Errors +open ClightPrinter + +let string_of_pos n = string_of_int (Extracted.Glue.int_of_matitapos n) + +let string_of_intensional_event = + function + Extracted.StructuredTraces.IEVcost cl -> + "COST(k_" ^ string_of_pos cl ^") " + | Extracted.StructuredTraces.IEVcall id -> + "CALL(fun_" ^ string_of_pos id ^ ") " + | Extracted.StructuredTraces.IEVtailcall _ -> assert false + | Extracted.StructuredTraces.IEVret id -> + "RET(fun_" ^ string_of_pos id ^ ") " +;; + +let string_of_pass = + function + | Extracted.Compiler.Clight_pass -> "Clight_pass " + | Extracted.Compiler.Clight_switch_removed_pass -> "Clight_switch_removed_pass" + | Extracted.Compiler.Clight_label_pass -> "Clight_label_pass " + | Extracted.Compiler.Clight_simplified_pass -> "Clight_simplified_pass " + | Extracted.Compiler.Cminor_pass -> "Cminor_pass " + | Extracted.Compiler.Rtlabs_pass -> "Rtlabs_pass " + | Extracted.Compiler.Rtl_separate_pass -> "Rtl_separate_pass " + | Extracted.Compiler.Rtl_uniq_pass -> "Rtl_uniq_pass " + | Extracted.Compiler.Ertl_pass -> "Ertl_pass " + | Extracted.Compiler.Ltl_pass -> "Ltl_pass " + | Extracted.Compiler.Lin_pass -> "Lin_pass " + | Extracted.Compiler.Assembly_pass -> "Assembly_pass " + | Extracted.Compiler.Object_code_pass -> "Object_code_pass " +;; + +List.iter (fun filename -> +let do_exec = Options.interpretations_requested () in +let cl = ClightParser.process filename in +let observe = + let rec infinity = Extracted.Nat.S infinity in + (fun pass prog -> + if do_exec || pass = Extracted.Compiler.Object_code_pass then + Printer.print_program filename pass prog; + if do_exec then + Extracted.Semantics.run_and_print pass prog infinity + (fun p -> print_string ("\n" ^ string_of_pass p ^ ": "); flush stdout; + Extracted.Types.It) + (fun evn -> print_string (string_of_intensional_event evn); flush stdout; + Extracted.Types.It) + (fun msg -> print_endline (Error.errormsg msg); flush stdout; + Extracted.Types.It) + (fun n-> print_endline (string_of_int(Extracted.Glue.int_of_bitvector n)); + flush stdout; Extracted.Types.It) + else + Extracted.Types.It) +in +let output = + match Extracted.Compiler.compile observe cl with + | OK o -> o + | Error m -> failwith (Error.errormsg m) in +if Options.annotation_requested () then + begin + let labelled = output.Extracted.Compiler.c_labelled_clight in + let l_costmap = output.Extracted.Compiler.c_clight_cost_map in + let init_costlabel = output.Extracted.Compiler.c_init_costlabel in + let s_costmap = output.Extracted.Compiler.c_stack_cost in + let maxstack = output.Extracted.Compiler.c_max_stack in + let style = Cost_instrumented (l_costmap,init_costlabel,s_costmap,maxstack) in + let instrumented = ClightPrinter.print_program style labelled in + let basename = + (match Options.get_output_files () with + None -> Filename.chop_extension filename + | Some s -> s) in + let och = open_out (basename ^ "-instrumented.c") in + output_string och instrumented; + close_out och; + let och = open_out (basename ^ ".cerco") in + output_string och "__cost\n"; + output_string och "__cost_incr\n"; + close_out och; + let och = open_out (basename ^ ".stack_cerco") in + output_string och "__stack_size\n"; + output_string och "__stack_size_max\n"; + output_string och "__stack_size_incr\n"; + close_out och + end +) (OptionsParsing.results ()) diff --git a/build b/build new file mode 100755 index 0000000..938a00d --- /dev/null +++ b/build @@ -0,0 +1,15 @@ +#!/bin/sh + +# A crappy build script that needs to be replaced by some proper structure. + +OCAMLC="ocamlc -I cparser" + +make -C cparser +(cd extracted; ./build) +cp extracted/_build/extracted.cm[io] . +$OCAMLC -c -g *.mli +$OCAMLC -c -g error.ml +$OCAMLC -c -g optionsParsing.ml +$OCAMLC -c -g options.ml +$OCAMLC -c -g *.ml +$OCAMLC -custom -g extracted.cmo ../Deliverables/D2.2/8051/lib/libcparser.a cparser/cparser.cma clightFromC.cmo clightParser.cmo IntelHex.cmo clightPrinter.cmo rTLabsPrinter.cmo ASMPrinter.cmo printer.cmo error.cmo optionsParsing.cmo options.cmo clightLustre.cmo clightLustreMain.cmo acc.cmo -o acc diff --git a/clightFromC.ml b/clightFromC.ml new file mode 100644 index 0000000..21d8b6c --- /dev/null +++ b/clightFromC.ml @@ -0,0 +1,985 @@ +(* Based on the prototype --- expect some obsolete definitions to be present *) + +open Printf + +open Cparser +open Cparser.C +open Cparser.Env + +open Extracted.Csyntax +open Extracted.AST +open Extracted.Vector +open Extracted.BitVector + +(* Integer conversion *) + +let rec convertIntNat n = + if n = 0 then Extracted.Nat.O else Extracted.Nat.S (convertIntNat (n-1)) + +let rec convertInt64Nat n = + if n = Int64.zero then Extracted.Nat.O else Extracted.Nat.S (convertInt64Nat (Int64.pred n)) + +let convertBool = function +| true -> Extracted.Bool.True +| false -> Extracted.Bool.False + +let rec convertIntBV len n = + match len with + | 0 -> VEmpty + | _ -> let l = len -1 in VCons (convertIntNat l, convertBool (Int64.logand n (Int64.shift_left Int64.one l) <> Int64.zero), convertIntBV l n) + +let convertInt sz n = + convertIntBV (match sz with I8 -> 8 | I16 -> 16 | I32 -> 32) n + +(** Extract the type part of a type-annotated Clight expression. *) + +let typeof e = match e with Expr(_,te) -> te + +(** Natural alignment of a type, in bytes. *) +let rec alignof = function + | Tvoid -> 1 + | Tint (I8,_) -> 1 + | Tint (I16,_) -> 2 + | Tint (I32,_) -> 4 + (*| Tfloat F32 -> 4 + | Tfloat F64 -> 8*) + | Tpointer _ -> 4 + | Tarray (t',n) -> alignof t' + | Tfunction (_,_) -> 1 + | Tstruct (_,fld) -> alignof_fields fld + | Tunion (_,fld) -> alignof_fields fld + | Tcomp_ptr _ -> 4 +and alignof_fields = function + | Fnil -> 1 + | Fcons (id,t, f') -> max (alignof t) (alignof_fields f') + +(** Size of a type, in bytes. *) + +let align n amount = + ((n + amount - 1) / amount) * amount + +let int_of_nat n = + let rec aux n i = + match n with + | Extracted.Nat.O -> i + | Extracted.Nat.S m -> aux m (i+1) + in aux n 0 + +let rec sizeof t = + match t with + | Tvoid -> 1 + | Tint (I8,_) -> 1 + | Tint (I16,_) -> 2 + | Tint (I32,_) -> 4 +(* | Tfloat F32 -> 4 + | Tfloat F64 -> 8*) + | Tpointer _ -> 4 + | Tarray (t',n) -> sizeof t' * max 1 (int_of_nat n) + | Tfunction (_,_) -> 1 + | Tstruct (_,fld) -> align (max 1 (sizeof_struct fld 0)) (alignof t) + | Tunion (_,fld) -> align (max 1 (sizeof_union fld)) (alignof t) + | Tcomp_ptr _ -> 4 +and sizeof_struct fld pos = + match fld with + | Fnil -> pos + | Fcons (id,t, fld') -> sizeof_struct fld' (align pos (alignof t) + sizeof t) +and sizeof_union = function + | Fnil -> 0 + | Fcons (id,t, fld') -> max (sizeof t) (sizeof_union fld') + +(** Record the declarations of global variables and associate them + with the corresponding atom. *) + +let decl_atom : (ident, Env.t * C.decl) Hashtbl.t = Hashtbl.create 103 + +(** Hooks -- overriden in machine-dependent CPragmas module *) + +let process_pragma_hook = ref (fun (s: string) -> false) +let define_variable_hook = ref (fun (id: ident) (d: C.decl) -> ()) +let define_function_hook = ref (fun (id: ident) (d: C.decl) -> ()) +let define_stringlit_hook = ref (fun (id: ident) -> ()) + +(** ** Error handling *) + +let currentLocation = ref Cutil.no_loc + +let updateLoc l = currentLocation := l + +let numErrors = ref 0 + +let error msg = + incr numErrors; + eprintf "%aError: %s\n" Cutil.printloc !currentLocation msg + +let unsupported msg = + incr numErrors; + eprintf "%aUnsupported feature: %s\n" Cutil.printloc !currentLocation msg + +let warning msg = + eprintf "%aWarning: %s\n" Cutil.printloc !currentLocation msg + +(** ** Identifier creation *) + +(* Rather than use the Matita name generators which have to be threaded + throughout definitions, we'll use an imperative generator here. *) + +let idGenerator = ref (Extracted.Identifiers.new_universe Extracted.PreIdentifiers.SymbolTag) +let idTable = Hashtbl.create 47 +let symTable = Hashtbl.create 47 +let make_id s = + try + Hashtbl.find idTable s + with Not_found -> + let { Extracted.Types.fst = id; Extracted.Types.snd = g} = Extracted.Identifiers.fresh Extracted.PreIdentifiers.SymbolTag !idGenerator in + idGenerator := g; + Hashtbl.add idTable s id; + Hashtbl.add symTable id s; + id + +(** ** Functions used to handle string literals *) + +let stringNum = ref 0 (* number of next global for string literals *) +let stringTable = Hashtbl.create 47 + +let name_for_string_literal env s = + try + Hashtbl.find stringTable s + with Not_found -> + incr stringNum; + let name = Printf.sprintf "__stringlit_%d" !stringNum in + let id = make_id name in + Hashtbl.add decl_atom id + (env, (C.Storage_static, + Env.fresh_ident name, + C.TPtr(C.TInt(C.IChar,[C.AConst]),[]), + None)); + !define_stringlit_hook id; + Hashtbl.add stringTable s id; + id + +let typeStringLiteral s = + Tarray(Tint(I8, Unsigned), convertIntNat (String.length s + 1)) + +let global_for_string s id = + let init = ref [] in + let add_char c = + init := + Init_int8(convertInt I8 (Int64.of_int (Char.code c))) + :: !init in + add_char '\000'; + for i = String.length s - 1 downto 0 do add_char s.[i] done; + ((id, !init), typeStringLiteral s) + +let globals_for_strings globs = + Hashtbl.fold + (fun s id l -> global_for_string s id :: l) + stringTable globs + +(** ** Handling of stubs for variadic functions *) + +let stub_function_table = Hashtbl.create 47 + +let register_stub_function name tres targs = + let rec letters_of_type = function + | Tnil -> [] + (*| Tfloat(_)::tl -> "f" :: letters_of_type tl*) + | Tcons (_, tl) -> "i" :: letters_of_type tl in + let stub_name = make_id + (name ^ "$" ^ String.concat "" (letters_of_type targs)) in + try + (stub_name, Hashtbl.find stub_function_table stub_name) + with Not_found -> + let rec types_of_types = function + | Tnil -> Tnil + (*| Tfloat(_)::tl -> Tfloat(F64)::(types_of_types tl)*) + | Tcons (_,tl) -> Tcons (Tpointer(Tvoid), types_of_types tl) in + let stub_type = Tfunction (types_of_types targs, tres) in + Hashtbl.add stub_function_table stub_name stub_type; + (stub_name, stub_type) + +let declare_stub_function stub_name stub_type = + match stub_type with + | Tfunction(targs, tres) -> + (stub_name, + CL_External(stub_name, targs, tres)) + | _ -> assert false + +let declare_stub_functions k = + Hashtbl.fold + (fun n i k -> declare_stub_function n i :: k) + stub_function_table k + +(** ** Translation functions *) + +(** Constants *) + + + +(** Types *) + +let convertIkind = function + | C.IBool -> unsupported "'_Bool' type"; (Unsigned, I8) + | C.IChar -> (Unsigned, I8) + | C.ISChar -> (Signed, I8) + | C.IUChar -> (Unsigned, I8) + | C.IInt -> (Signed, I32) + | C.IUInt -> (Unsigned, I32) + | C.IShort -> (Signed, I16) + | C.IUShort -> (Unsigned, I16) + | C.ILong -> (Signed, I32) + | C.IULong -> (Unsigned, I32) + | C.ILongLong -> + (*if not !ClightFlags.option_flonglong then*) unsupported "'long long' type"; + (Signed, I32) + | C.IULongLong -> + (*if not !ClightFlags.option_flonglong then*) unsupported "'unsigned long long' type"; + (Unsigned, I32) + +(* +let convertFkind = function + | C.FFloat -> F32 + | C.FDouble -> F64 + | C.FLongDouble -> + if not !ClightFlags.option_flonglong then unsupported "'long double' type"; + F64 +*) + +let convertTyp env t = + + let rec convertTyp seen t = + match Cutil.unroll env t with + | C.TVoid a -> Tvoid + | C.TInt(ik, a) -> + let (sg, sz) = convertIkind ik in Tint(sz, sg) + | C.TFloat(fk, a) -> unsupported "float type"; Tvoid + (*Tfloat(convertFkind fk)*) + | C.TPtr(C.TStruct(id, _), _) when List.mem id seen -> + Tcomp_ptr(make_id ("struct " ^ id.name)) + | C.TPtr(C.TUnion(id, _), _) when List.mem id seen -> + Tcomp_ptr(make_id ("union " ^ id.name)) + | C.TPtr(ty, a) -> + Tpointer(convertTyp seen ty) + | C.TArray(ty, None, a) -> + (* Cparser verified that the type ty[] occurs only in + contexts that are safe for Clight, so just treat as ty[0]. *) + (* warning "array type of unspecified size"; *) + Tarray(convertTyp seen ty, Extracted.Nat.O) + | C.TArray(ty, Some sz, a) -> + Tarray(convertTyp seen ty, convertInt64Nat sz ) + | C.TFun(tres, targs, va, a) -> + if va then unsupported "variadic function type"; + if Cutil.is_composite_type env tres then + unsupported "return type is a struct or union"; + Tfunction(begin match targs with + | None -> warning "un-prototyped function type"; Tnil + | Some tl -> convertParams seen tl + end, + convertTyp seen tres) + | C.TNamed _ -> + assert false + | C.TStruct(id, a) -> + let flds = + try + convertFields (id :: seen) (Env.find_struct env id) + with Env.Error e -> + error (Env.error_message e); Fnil in + Tstruct(make_id ("struct " ^ id.name), flds) + | C.TUnion(id, a) -> + let flds = + try + convertFields (id :: seen) (Env.find_union env id) + with Env.Error e -> + error (Env.error_message e); Fnil in + Tunion(make_id ("union " ^ id.name), flds) + + and convertParams seen = function + | [] -> Tnil + | (id, ty) :: rem -> + if Cutil.is_composite_type env ty then + unsupported "function parameter of struct or union type"; + Tcons (convertTyp seen ty, convertParams seen rem) + + and convertFields seen ci = + convertFieldList seen ci.Env.ci_members + + and convertFieldList seen = function + | [] -> Fnil + | f :: fl -> + if f.fld_bitfield <> None then + unsupported "bit field in struct or union"; + Fcons (make_id f.fld_name, convertTyp seen f.fld_typ, + convertFieldList seen fl) + + in convertTyp [] t + +let rec convertTypList env = function + | [] -> Tnil + | t1 :: tl -> Tcons (convertTyp env t1, convertTypList env tl) + +(** Expressions *) + +let ezero = Expr(Econst_int(I32, zero (convertIntNat 32)), Tint(I32, Signed)) + +let is_pointer = function +| Tpointer _ -> true +| _ -> false + +let rec convertExpr env e = + let ty = convertTyp env e.etyp in + match e.edesc with + | C.EConst(C.CInt(i, _, _)) when i = Int64.zero && is_pointer ty -> + Expr(Ecast (ty, Expr (Econst_int (I8,zero (convertIntNat 8)), Tint (I8, Unsigned))), ty) + | C.EConst(C.CInt(i, k, _)) -> + let (_,sz) = convertIkind k in + Expr(Econst_int(sz, convertInt sz i), ty) + | C.EConst(C.CFloat(f, _, _)) -> unsupported "float constant"; ezero + (*Expr(Econst_float f, ty)*) + | C.EConst(C.CStr s) -> + Expr(Evar(name_for_string_literal env s), typeStringLiteral s) + | C.EConst(C.CWStr s) -> + unsupported "wide string literal"; ezero + | C.EConst(C.CEnum(id, i)) -> + let sz = match ty with Tint (sz, _) -> sz | _ -> I32 in + Expr(Econst_int(sz, convertInt sz i), ty) + + | C.ESizeof ty1 -> + Expr(Esizeof(convertTyp env ty1), ty) + | C.EVar id -> + Expr(Evar(make_id id.name), ty) + + | C.EUnop(C.Oderef, e1) -> + Expr(Ederef(convertExpr env e1), ty) + | C.EUnop(C.Oaddrof, e1) -> + Expr(Eaddrof(convertExpr env e1), ty) + | C.EUnop(C.Odot id, e1) -> + Expr(Efield(convertExpr env e1, make_id id), ty) + | C.EUnop(C.Oarrow id, e1) -> + let e1' = convertExpr env e1 in + let ty1 = + match typeof e1' with + | Tpointer t -> t + | _ -> error ("wrong type for ->" ^ id ^ " access"); Tvoid in + Expr(Efield(Expr(Ederef(convertExpr env e1), ty1), + make_id id), ty) + | C.EUnop(C.Oplus, e1) -> + convertExpr env e1 + | C.EUnop(C.Ominus, e1) -> + Expr(Eunop(Oneg, convertExpr env e1), ty) + | C.EUnop(C.Olognot, e1) -> + Expr(Eunop(Onotbool, convertExpr env e1), ty) + | C.EUnop(C.Onot, e1) -> + Expr(Eunop(Onotint, convertExpr env e1), ty) + | C.EUnop(_, _) -> + unsupported "pre/post increment/decrement operator"; ezero + + | C.EBinop(C.Oindex, e1, e2, _) -> + Expr(Ederef(Expr(Ebinop(Oadd, convertExpr env e1, convertExpr env e2), + Tpointer ty)), ty) + | C.EBinop(C.Ologand, e1, e2, _) -> + Expr(Eandbool(convertExpr env e1, convertExpr env e2), ty) + | C.EBinop(C.Ologor, e1, e2, _) -> + Expr(Eorbool(convertExpr env e1, convertExpr env e2), ty) + | C.EBinop(op, e1, e2, _) -> + let op' = + match op with + | C.Oadd -> Oadd + | C.Osub -> Osub + | C.Omul -> Omul + | C.Odiv -> Odiv + | C.Omod -> Omod + | C.Oand -> Oand + | C.Oor -> Oor + | C.Oxor -> Oxor + | C.Oshl -> Oshl + | C.Oshr -> Oshr + | C.Oeq -> Oeq + | C.One -> One + | C.Olt -> Olt + | C.Ogt -> Ogt + | C.Ole -> Ole + | C.Oge -> Oge + | C.Ocomma -> unsupported "sequence operator"; Oadd + | _ -> unsupported "assignment operator"; Oadd in + Expr(Ebinop(op', convertExpr env e1, convertExpr env e2), ty) + | C.EConditional(e1, e2, e3) -> + Expr(Econdition(convertExpr env e1, convertExpr env e2, convertExpr env e3), ty) + | C.ECast(ty1, e1) -> + Expr(Ecast(convertTyp env ty1, convertExpr env e1), ty) + | C.ECall _ -> + unsupported "function call within expression"; ezero + +(* Function calls *) + +let rec projFunType env ty = + match Cutil.unroll env ty with + | TFun(res, args, vararg, attr) -> Some(res, vararg) + | TPtr(ty', attr) -> projFunType env ty' + | _ -> None + +let rec convertList l = + match l with + | [] -> Extracted.List.Nil + | h::t -> Extracted.List.Cons (h,convertList t) + +let convertFuncall env lhs fn args = + match projFunType env fn.etyp with + | None -> + error "wrong type for function part of a call"; Sskip + | Some(res, false) -> + (* Non-variadic function *) + Scall(lhs, convertExpr env fn, convertList (List.map (convertExpr env) args)) + | Some(res, true) -> + (* Variadic function: generate a call to a stub function with + the appropriate number and types of arguments. Works only if + the function expression e is a global variable. *) + let fun_name = + match fn with + | {edesc = C.EVar id} when false (* FIXME? !ClightFlags.option_fvararg_calls *)-> + (*warning "emulating call to variadic function"; *) + id.name + | _ -> + unsupported "call to variadic function"; + "" in + let targs = convertTypList env (List.map (fun e -> e.etyp) args) in + let tres = convertTyp env res in + let (stub_fun_name, stub_fun_typ) = + register_stub_function fun_name tres targs in + Scall(lhs, + Expr(Evar(stub_fun_name), stub_fun_typ), + convertList (List.map (convertExpr env) args)) + +(* Handling of volatile *) + +let is_volatile_access env e = + List.mem C.AVolatile (Cutil.attributes_of_type env e.etyp) + && Cutil.is_lvalue env e + +let volatile_fun_suffix_type ty = + match ty with + | Tint(I8, Unsigned) -> ("int8unsigned", ty) + | Tint(I8, Signed) -> ("int8signed", ty) + | Tint(I16, Unsigned) -> ("int16unsigned", ty) + | Tint(I16, Signed) -> ("int16signed", ty) + | Tint(I32, _) -> ("int32", Tint(I32, Signed)) + (*| Tfloat F32 -> ("float32", ty) + | Tfloat F64 -> ("float64", ty)*) + | Tpointer _ | Tarray _ | Tfunction _ | Tcomp_ptr _ -> + ("pointer", Tpointer Tvoid) + | _ -> + unsupported "operation on volatile struct or union"; ("", Tvoid) + +let volatile_read_fun ty = + let (suffix, ty') = volatile_fun_suffix_type ty in + Expr(Evar(make_id ("__builtin_volatile_read_" ^ suffix)), + Tfunction(Tcons (Tpointer Tvoid, Tnil), ty')) + +let volatile_write_fun ty = + let (suffix, ty') = volatile_fun_suffix_type ty in + Expr(Evar(make_id ("__builtin_volatile_write_" ^ suffix)), + Tfunction(Tcons (Tpointer Tvoid, Tcons (ty', Tnil)), Tvoid)) + +(* Toplevel expression, argument of an Sdo *) + +let convertTopExpr env e = + match e.edesc with + | C.EBinop(C.Oassign, lhs, {edesc = C.ECall(fn, args)}, _) -> + convertFuncall env (Extracted.Types.Some (convertExpr env lhs)) fn args + | C.EBinop(C.Oassign, lhs, rhs, _) -> + if Cutil.is_composite_type env lhs.etyp then + unsupported "assignment between structs or between unions"; + let lhs' = convertExpr env lhs + and rhs' = convertExpr env rhs in + begin match (is_volatile_access env lhs, is_volatile_access env rhs) with + | true, true -> (* should not happen *) + unsupported "volatile-to-volatile assignment"; + Sskip + | false, true -> (* volatile read *) + Scall(Extracted.Types.Some lhs', + volatile_read_fun (typeof rhs'), + convertList [ Expr (Eaddrof rhs', Tpointer (typeof rhs')) ]) + | true, false -> (* volatile write *) + Scall(Extracted.Types.None, + volatile_write_fun (typeof lhs'), + convertList [ Expr(Eaddrof lhs', Tpointer (typeof lhs')); rhs' ]) + | false, false -> (* regular assignment *) + Sassign(convertExpr env lhs, convertExpr env rhs) + end + | C.ECall(fn, args) -> + convertFuncall env Extracted.Types.None fn args + | _ -> + unsupported "illegal toplevel expression"; Sskip + +(* Separate the cases of a switch statement body *) + +type switchlabel = + | Case of C.exp + | Default + +type switchbody = + | Label of switchlabel + | Stmt of C.stmt + +let rec flattenSwitch = function + | {sdesc = C.Sseq(s1, s2)} -> + flattenSwitch s1 @ flattenSwitch s2 + | {sdesc = C.Slabeled(C.Scase e, s1)} -> + Label(Case e) :: flattenSwitch s1 + | {sdesc = C.Slabeled(C.Sdefault, s1)} -> + Label Default :: flattenSwitch s1 + | s -> + [Stmt s] + +let rec groupSwitch = function + | [] -> + (Cutil.sskip, []) + | Label case :: rem -> + let (fst, cases) = groupSwitch rem in + (Cutil.sskip, (case, fst) :: cases) + | Stmt s :: rem -> + let (fst, cases) = groupSwitch rem in + (Cutil.sseq s.sloc s fst, cases) + +(* Statement *) + +let rec convertStmt env s = + updateLoc s.sloc; + match s.sdesc with + | C.Sskip -> + Sskip + | C.Sdo e -> + convertTopExpr env e + | C.Sseq(s1, s2) -> + Ssequence(convertStmt env s1, convertStmt env s2) + | C.Sif(e, s1, s2) -> + Sifthenelse(convertExpr env e, convertStmt env s1, convertStmt env s2) + | C.Swhile(e, s1) -> + Swhile(convertExpr env e, convertStmt env s1) + | C.Sdowhile(s1, e) -> + Sdowhile(convertExpr env e, convertStmt env s1) + | C.Sfor(s1, e, s2, s3) -> + Sfor(convertStmt env s1, convertExpr env e, convertStmt env s2, + convertStmt env s3) + | C.Sbreak -> + Sbreak + | C.Scontinue -> + Scontinue + | C.Sswitch(e, s1) -> + let (init, cases) = groupSwitch (flattenSwitch s1) in + if cases = [] then + unsupported "ill-formed 'switch' statement"; + if init.sdesc <> C.Sskip then + warning "ignored code at beginning of 'switch'"; + let e' = convertExpr env e in + let sz = match typeof e' with Tint(sz,_) -> sz | _ -> I32 in + Sswitch(e', convertSwitch env sz cases) + | C.Slabeled(C.Slabel lbl, s1) -> + Slabel(make_id lbl, convertStmt env s1) + | C.Slabeled(C.Scase _, _) -> + unsupported "'case' outside of 'switch'"; Sskip + | C.Slabeled(C.Sdefault, _) -> + unsupported "'default' outside of 'switch'"; Sskip + | C.Sgoto lbl -> + Sgoto(make_id lbl) + | C.Sreturn None -> + Sreturn Extracted.Types.None + | C.Sreturn(Some e) -> + Sreturn(Extracted.Types.Some(convertExpr env e)) + | C.Sblock _ -> + unsupported "nested blocks"; Sskip + | C.Sdecl _ -> + unsupported "inner declarations"; Sskip + +and convertSwitch env sz = function + | [] -> + LSdefault Sskip + | [Default, s] -> + LSdefault (convertStmt env s) + | (Default, s) :: _ -> + updateLoc s.sloc; + unsupported "'default' case must occur last"; + LSdefault Sskip + | (Case e, s) :: rem -> + updateLoc s.sloc; + let v = + match Ceval.integer_expr env e with + | None -> unsupported "'case' label is not a compile-time integer"; 0L + | Some v -> v in + LScase(sz, + convertInt sz v, + convertStmt env s, + convertSwitch env sz rem) + +(** Function definitions *) + +let convertProd (x,y) = {Extracted.Types.fst = x; Extracted.Types.snd = y} + +let convertFundef env fd = + if Cutil.is_composite_type env fd.fd_ret then + unsupported "function returning a struct or union"; + let ret = + convertTyp env fd.fd_ret in + let params = + List.map + (fun (id, ty) -> + if Cutil.is_composite_type env ty then + unsupported "function parameter of struct or union type"; + convertProd (make_id id.name, convertTyp env ty)) + fd.fd_params in + let vars = + List.map + (fun (sto, id, ty, init) -> + if sto = Storage_extern || sto = Storage_static then + unsupported "'static' or 'extern' local variable"; + if init <> None then + unsupported "initialized local variable"; + convertProd (make_id id.name, convertTyp env ty)) + fd.fd_locals in + let body' = convertStmt env fd.fd_body in + let id' = make_id fd.fd_name.name in + let decl = + (fd.fd_storage, fd.fd_name, Cutil.fundef_typ fd, None) in + Hashtbl.add decl_atom id' (env, decl); + !define_function_hook id' decl; + (id', + CL_Internal {fn_return = ret; fn_params = convertList params; + fn_vars = convertList vars; fn_body = body'}) + +(** External function declaration *) + +let convertFundecl env (sto, id, ty, optinit) = + match convertTyp env ty with + | Tfunction(args, res) -> + let id' = make_id id.name in + (id', CL_External(id', args, res)) + | _ -> + assert false + +(** Initializers *) + +let init_data_of_string s = + let id = ref [] in + let enter_char c = + let n = convertInt I8 (Int64.of_int (Char.code c)) in + id := Init_int8 n :: !id in + enter_char '\000'; + for i = String.length s - 1 downto 0 do enter_char s.[i] done; + !id + +let convertInit env ty init = + + let k = ref [] + and pos = ref 0 in + let emit size datum = + k := datum :: !k; + pos := !pos + size in + let emit_space size = + emit size (Init_space (convertIntNat size)) in + let align size = + let n = !pos land (size - 1) in + if n > 0 then emit_space (size - n) in + let check_align size = + assert (!pos land (size - 1) = 0) in + + let rec reduceInitExpr = function + | { edesc = C.EVar id; etyp = ty } -> + begin match Cutil.unroll env ty with + | C.TArray _ | C.TFun _ -> Some id + | _ -> None + end + | {edesc = C.EUnop(C.Oaddrof, {edesc = C.EVar id})} -> Some id + | {edesc = C.ECast(ty, e)} -> reduceInitExpr e + | _ -> None in + + let rec cvtInit ty = function + | Init_single e -> + begin match reduceInitExpr e with + | Some id -> + check_align 4; + emit 4 (Init_addrof(make_id id.name, convertIntNat 0)) + | None -> + match Ceval.constant_expr env ty e with + | Some(C.CInt(v, ik, _)) -> + begin match ty with + | TPtr(_,_) -> + (* The only integer constant that is a pointer is zero *) + emit 2 Init_null + | _ -> + begin match convertIkind ik with + | (_, I8) -> + emit 1 (Init_int8(convertInt I8 v)) + | (_, I16) -> + check_align 2; + emit 2 (Init_int16(convertInt I16 v)) + | (_, I32) -> + check_align 4; + emit 4 (Init_int32(convertInt I32 v)) + end + end + | Some(C.CFloat(v, fk, _)) -> + unsupported "floats" + (*begin match convertFkind fk with + | F32 -> + check_align 4; + emit 4 (Init_float32 v) + | F64 -> + check_align 8; + emit 8 (Init_float64 v) + end*) + | Some(C.CStr s) -> + check_align 4; + let id = name_for_string_literal env s in + emit 4 (Init_addrof(id, convertIntNat 0)) + | Some(C.CWStr _) -> + unsupported "wide character strings" + | Some(C.CEnum _) -> + error "enum tag after constant folding" + | None -> + error "initializer is not a compile-time constant" + end + | Init_array il -> + let ty_elt = + match Cutil.unroll env ty with + | C.TArray(t, _, _) -> t + | _ -> error "array type expected in initializer"; C.TVoid [] in + List.iter (cvtInit ty_elt) il + | Init_struct(_, flds) -> + cvtPadToSizeof ty (fun () -> List.iter cvtFieldInit flds) + | Init_union(_, fld, i) -> + cvtPadToSizeof ty (fun () -> cvtFieldInit (fld,i)) + + and cvtFieldInit (fld, i) = + let ty' = convertTyp env fld.fld_typ in + let al = alignof ty' in + align al; + cvtInit fld.fld_typ i + + and cvtPadToSizeof ty fn = + let ty' = convertTyp env ty in + let sz = sizeof ty' in + let pos0 = !pos in + fn(); + let pos1 = !pos in + assert (pos1 <= pos0 + sz); + if pos1 < pos0 + sz then emit_space (pos0 + sz - pos1) + + in cvtInit ty init; List.rev !k + +(** Global variable *) + +let convertGlobvar env (sto, id, ty, optinit as decl) = + let id' = make_id id.name in + let ty' = convertTyp env ty in + let init' = + match optinit with + | None -> + if sto = C.Storage_extern then [] else [Init_space(convertIntNat (sizeof ty'))] + | Some i -> + convertInit env ty i in + Hashtbl.add decl_atom id' (env, decl); + !define_variable_hook id' decl; + ((id', init'), ty') + +(** Convert a list of global declarations. + Result is a pair [(funs, vars)] where [funs] are + the function definitions (internal and external) + and [vars] the variable declarations. *) + +let rec convertGlobdecls env funs vars gl = + match gl with + | [] -> (List.rev funs, List.rev vars) + | g :: gl' -> + updateLoc g.gloc; + match g.gdesc with + | C.Gdecl((sto, id, ty, optinit) as d) -> + (* Prototyped functions become external declarations. + Variadic functions are skipped. + Other types become variable declarations. *) + begin match Cutil.unroll env ty with + | TFun(_, Some _, false, _) -> + convertGlobdecls env (convertFundecl env d :: funs) vars gl' + | TFun(_, None, false, _) -> + error "function declaration without prototype"; + convertGlobdecls env funs vars gl' + | TFun(_, _, true, _) -> + convertGlobdecls env funs vars gl' + | _ -> + convertGlobdecls env funs (convertGlobvar env d :: vars) gl' + end + | C.Gfundef fd -> + convertGlobdecls env (convertFundef env fd :: funs) vars gl' + | C.Gcompositedecl _ | C.Gcompositedef _ + | C.Gtypedef _ | C.Genumdef _ -> + (* typedefs are unrolled, structs are expanded inline, and + enum tags are folded. So we just skip their declarations. *) + convertGlobdecls env funs vars gl' + | C.Gpragma s -> + if not (!process_pragma_hook s) then + warning ("'#pragma " ^ s ^ "' directive ignored"); + convertGlobdecls env funs vars gl' + +(** Build environment of typedefs and structs *) + +let rec translEnv env = function + | [] -> env + | g :: gl -> + let env' = + match g.gdesc with + | C.Gcompositedecl(su, id) -> + Env.add_composite env id (Cutil.composite_info_decl env su) + | C.Gcompositedef(su, id, fld) -> + Env.add_composite env id (Cutil.composite_info_def env su fld) + | C.Gtypedef(id, ty) -> + Env.add_typedef env id ty + | _ -> + env in + translEnv env' gl + +(** Eliminate forward declarations of globals that are defined later. *) + +module IdentSet = Set.Make(struct type t = C.ident let compare = compare end) + +let cleanupGlobals p = + + let rec clean defs accu = function + | [] -> accu + | g :: gl -> + updateLoc g.gloc; + match g.gdesc with + | C.Gdecl(sto, id, ty, None) -> + if IdentSet.mem id defs + then clean defs accu gl + else clean (IdentSet.add id defs) (g :: accu) gl + | C.Gdecl(_, id, ty, _) -> + if IdentSet.mem id defs then + error ("multiple definitions of " ^ id.name); + clean (IdentSet.add id defs) (g :: accu) gl + | C.Gfundef fd -> + if IdentSet.mem fd.fd_name defs then + error ("multiple definitions of " ^ fd.fd_name.name); + clean (IdentSet.add fd.fd_name defs) (g :: accu) gl + | _ -> + clean defs (g :: accu) gl + + in clean IdentSet.empty [] (List.rev p) + +(** Convert a [C.program] into a [Csyntax.program] *) + +let convertCLVar ((x,y),z) = + {Extracted.Types.fst = {Extracted.Types.fst = x; Extracted.Types.snd = XData}; + Extracted.Types.snd = {Extracted.Types.fst = convertList y; Extracted.Types.snd = z}} + +let convertProgram (p:C.program) : clight_program option = + numErrors := 0; + idGenerator := Extracted.Identifiers.new_universe Extracted.PreIdentifiers.SymbolTag; + stringNum := 0; + Hashtbl.clear decl_atom; + Hashtbl.clear idTable; + Hashtbl.clear stringTable; + Hashtbl.clear stub_function_table; + (* Hack: externals are problematic for Cerco. TODO *) + let p = (* Builtins.declarations() @ *) p in + try + let (funs1, vars1) = + convertGlobdecls (translEnv Env.empty p) [] [] (cleanupGlobals p) in + let funs2 = declare_stub_functions funs1 in + let main = make_id "main" in + let vars2 = globals_for_strings vars1 in + if !numErrors > 0 + then None + else Some { prog_funct = convertList (List.map convertProd funs2); + prog_vars = convertList (List.map convertCLVar vars2); + prog_main = main } + with Env.Error msg -> + error (Env.error_message msg); None + +(** ** Extracting information about global variables from their atom *) + +let rec type_is_readonly env t = + let a = Cutil.attributes_of_type env t in + if List.mem C.AVolatile a then false else + if List.mem C.AConst a then true else + match Cutil.unroll env t with + | C.TArray(t', _, _) -> type_is_readonly env t' + | _ -> false + +let atom_is_static a = + try + let (env, (sto, id, ty, init)) = Hashtbl.find decl_atom a in + sto = C.Storage_static + with Not_found -> + false + +let atom_is_readonly a = + try + let (env, (sto, id, ty, init)) = Hashtbl.find decl_atom a in + type_is_readonly env ty + with Not_found -> + false + +let atom_sizeof a = + try + let (env, (sto, id, ty, init)) = Hashtbl.find decl_atom a in + Cutil.sizeof env ty + with Not_found -> + None + +let atom_alignof a = + try + let (env, (sto, id, ty, init)) = Hashtbl.find decl_atom a in + Cutil.alignof env ty + with Not_found -> + None + +(** ** The builtin environment *) + +open Builtins + +let builtins_generic = { + typedefs = [ + (* keeps GCC-specific headers happy, harmless for others *) + "__builtin_va_list", C.TPtr(C.TVoid [], []) + ]; + functions = [ + (* The volatile read/volatile write functions *) + "__builtin_volatile_read_int8unsigned", + (TInt(IUChar, []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_read_int8signed", + (TInt(ISChar, []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_read_int16unsigned", + (TInt(IUShort, []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_read_int16signed", + (TInt(IShort, []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_read_int32", + (TInt(IInt, []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_read_float32", + (TFloat(FFloat, []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_read_float64", + (TFloat(FDouble, []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_read_pointer", + (TPtr(TVoid [], []), [TPtr(TVoid [], [])], false); + "__builtin_volatile_write_int8unsigned", + (TVoid [], [TPtr(TVoid [], []); TInt(IUChar, [])], false); + "__builtin_volatile_write_int8signed", + (TVoid [], [TPtr(TVoid [], []); TInt(ISChar, [])], false); + "__builtin_volatile_write_int16unsigned", + (TVoid [], [TPtr(TVoid [], []); TInt(IUShort, [])], false); + "__builtin_volatile_write_int16signed", + (TVoid [], [TPtr(TVoid [], []); TInt(IShort, [])], false); + "__builtin_volatile_write_int32", + (TVoid [], [TPtr(TVoid [], []); TInt(IInt, [])], false); + "__builtin_volatile_write_float32", + (TVoid [], [TPtr(TVoid [], []); TFloat(FFloat, [])], false); + "__builtin_volatile_write_float64", + (TVoid [], [TPtr(TVoid [], []); TFloat(FDouble, [])], false); + "__builtin_volatile_write_pointer", + (TVoid [], [TPtr(TVoid [], []); TPtr(TVoid [], [])], false) + ] +} + +(* Add processor-dependent builtins *) + +let builtins = + { typedefs = builtins_generic.typedefs @ CBuiltins.builtins.typedefs; + functions = builtins_generic.functions @ CBuiltins.builtins.functions + } + diff --git a/clightParser.ml b/clightParser.ml new file mode 100644 index 0000000..f9f2ffc --- /dev/null +++ b/clightParser.ml @@ -0,0 +1,51 @@ +let safe_remove name = + try Sys.remove name with Sys_error _ -> () + +let process ?is_lustre_file ?remove_lustre_externals file = + let temp_dir = Filename.dirname file in + let tmp_file1 = Filename.temp_file ~temp_dir "cparser1" ".c" + and tmp_file2 = Filename.temp_file ~temp_dir "cparser2" ".i" + and prepro_opts = [] in + + (* Add CerCo's primitives *) + let _ = + try + let oc = open_out tmp_file1 in + if is_lustre_file = Some true || remove_lustre_externals = Some true then + output_string oc "#include"; + (* FIXME output_string oc Primitive.prototypes ;*) + close_out oc + with Sys_error _ -> failwith "Error adding primitive prototypes." in + let rc = Sys.command + (Printf.sprintf "cat %s >> %s" + (Filename.quote file) (Filename.quote tmp_file1)) in + if rc <> 0 then ( + safe_remove tmp_file1; + failwith "Error adding primitive prototypes." + ); + + (* Preprocessing *) + Cparser.Builtins.set Cparser.GCC.builtins; + let rc = Sys.command + (Printf.sprintf "gcc -E -U__GNUC__ %s %s > %s" + (String.concat " " (List.map Filename.quote prepro_opts)) + (Filename.quote tmp_file1) (Filename.quote tmp_file2)) in + if rc <> 0 then ( + safe_remove tmp_file1; + safe_remove tmp_file2; + failwith "Error calling gcc." + ); + + (* C to Cil *) + let r = Cparser.Parse.preprocessed_file "CSf" file tmp_file2 in + match r with + | None -> failwith "Error during C parsing." + | Some p -> + (* Cil to Clight *) + (match ClightFromC.convertProgram p with + | None -> failwith "Error during C to Clight pass." + | Some(pp) -> + safe_remove tmp_file1; + safe_remove tmp_file2; + if remove_lustre_externals = Some true then failwith "not implemented yet" (*ClightLustre.simplify pp*) + else pp) diff --git a/clightParser.mli b/clightParser.mli new file mode 100644 index 0000000..3a1bbfb --- /dev/null +++ b/clightParser.mli @@ -0,0 +1,9 @@ +(** This module implements a parser for [C] based on [gcc] and + [CIL]. *) + +(** [process ?is_lustre_file ?remove_lustre_externals filename] parses the + contents of [filename] to obtain an abstract syntax tree that represents a + Clight program. *) +val process : + ?is_lustre_file:bool -> ?remove_lustre_externals:bool -> + string -> Extracted.Csyntax.clight_program diff --git a/clightPrinter.ml b/clightPrinter.ml new file mode 100644 index 0000000..6e8a728 --- /dev/null +++ b/clightPrinter.ml @@ -0,0 +1,692 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* 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 file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printer for Csyntax *) + +open Format +open Extracted.AST +open Extracted.Csyntax +open Extracted.Glue + +let freshNameCounter = ref 0 +let nameof id = + try + Hashtbl.find ClightFromC.symTable id + with Not_found -> + freshNameCounter := !freshNameCounter + 1; + let name = "_cerco" ^ string_of_int (!freshNameCounter) in + Hashtbl.add ClightFromC.symTable id name; + name + +let rec mListIter f l = +match l with +| Extracted.List.Nil -> () +| Extracted.List.Cons (h,t) -> f h; mListIter f t + +let rec mlist l = +match l with +| Extracted.List.Nil -> [] +| Extracted.List.Cons (h,t) -> h::(mlist t) + +let stack_cost_for scm id = + let check ids = + let id' = Extracted.Types.fst ids in + match Extracted.Identifiers.eq_identifier Extracted.PreIdentifiers.SymbolTag id id' with + | Extracted.Bool.True -> Extracted.Types.Some (Extracted.Types.snd ids) + | _ -> Extracted.Types.None + in + match Extracted.List.find check scm with + | Extracted.Types.None -> 0 + | Extracted.Types.Some n -> int_of_matitanat n + + +let rec flist l = +match l with +| Fnil -> [] +| Fcons (id, ty, tl) -> (nameof id,ty)::(flist tl) + +type cost_style = +| Cost_plain +| Cost_numbered of Extracted.Label.clight_cost_map * Extracted.CostLabel.costlabel * Extracted.Joint.stack_cost_model * Extracted.Nat.nat +| Cost_instrumented of Extracted.Label.clight_cost_map * Extracted.CostLabel.costlabel * Extracted.Joint.stack_cost_model * Extracted.Nat.nat + +(* Not ideal, but convenient for now *) +let style = ref Cost_plain + +let namecost l = + "_cost" ^ string_of_int (int_of_matitapos l) + +let name_unop = function + | Onotbool -> "!" + | Onotint -> "~" + | Oneg -> "-" + + +let name_binop = function + | Oadd -> "+" + | Osub -> "-" + | Omul -> "*" + | Odiv -> "/" + | Omod -> "%" + | Oand -> "&" + | Oor -> "|" + | Oxor -> "^" + | Oshl -> "<<" + | Oshr -> ">>" + | Oeq -> "==" + | One -> "!=" + | Olt -> "<" + | Ogt -> ">" + | Ole -> "<=" + | Oge -> ">=" + +let name_inttype sz sg = + match sz, sg with + | I8, Signed -> "signed char" + | I8, Unsigned -> "unsigned char" + | I16, Signed -> "short" + | I16, Unsigned -> "unsigned short" + | I32, Signed -> "int" + | I32, Unsigned -> "unsigned int" + +(* +let name_floattype sz = + match sz with + | F32 -> "float" + | F64 -> "double" +*) + +(* Collecting the names and fields of structs and unions *) + +module StructUnionSet = Set.Make(struct + type t = string * fieldlist + let compare (n1, _ : t) (n2, _ : t) = compare n1 n2 +end) + +let struct_unions = ref StructUnionSet.empty + +let register_struct_union id fld = + struct_unions := StructUnionSet.add (id, fld) !struct_unions + +(* Declarator (identifier + type) *) + +let name_optid id = + if id = "" then "" else " " ^ id + +let parenthesize_if_pointer id = + if String.length id > 0 && id.[0] = '*' then "(" ^ id ^ ")" else id + +let rec name_cdecl id ty = + match ty with + | Tvoid -> + "void" ^ name_optid id + | Tint(sz, sg) -> + name_inttype sz sg ^ name_optid id + (*| Tfloat sz -> + name_floattype sz ^ name_optid id*) + | Tpointer t -> + name_cdecl ("*" ^ id) t + | Tarray(t, n) -> + name_cdecl + (sprintf "%s[%ld]" (parenthesize_if_pointer id) (Int32.of_int (int_of_matitanat n))) + t + | Tfunction(args, res) -> + let b = Buffer.create 20 in + if id = "" + then Buffer.add_string b "(*)" + else Buffer.add_string b (parenthesize_if_pointer id); + Buffer.add_char b '('; + begin match args with + | Tnil -> + Buffer.add_string b "void" + | _ -> + let rec add_args first = function + | Tnil -> () + | Tcons (t1, tl) -> + if not first then Buffer.add_string b ", "; + Buffer.add_string b (name_cdecl "" t1); + add_args false tl in + add_args true args + end; + Buffer.add_char b ')'; + name_cdecl (Buffer.contents b) res + | Tstruct(name, fld) -> + (nameof name) ^ name_optid id + | Tunion(name, fld) -> + (nameof name) ^ name_optid id + | Tcomp_ptr name -> + (nameof name) ^ " *" ^ id + +(* Type *) + +let name_type ty = name_cdecl "" ty + +(* Expressions *) + +let parenthesis_level (Expr (e, ty)) = + match e with + | Econst_int _ -> 0 + (*| Econst_float _ -> 0*) + | Evar _ -> 0 + | Eunop(_, _) -> 30 + | Ederef _ -> 20 + | Eaddrof _ -> 30 + | Ebinop(op, _, _) -> + begin match op with + | Oand | Oor | Oxor -> 75 + | Oeq | One | Olt | Ogt | Ole | Oge -> 70 + | Oadd | Osub | Oshl | Oshr -> 60 + | Omul | Odiv | Omod -> 40 + end + | Ecast _ -> 30 + | Econdition(_, _, _) -> 80 + | Eandbool(_, _) -> 80 + | Eorbool(_, _) -> 80 + | Esizeof _ -> 20 + | Efield _ -> 20 + | Ecost (_,_) -> 20 + (*| Ecall (_,_,_) -> 20*) + +let rec print_expr p (Expr (eb, ty) as e) = + let level = parenthesis_level e in + match eb with + | Econst_int (_,n) -> + fprintf p "%ld" (Int32.of_int (int_of_bitvector n)) + (*| Econst_float f -> + fprintf p "%F" f*) + | Evar id -> + fprintf p "%s" (nameof id) + | Eunop(op, e1) -> + fprintf p "%s%a" (name_unop op) print_expr_prec (level, e1) + | Ederef (Expr (Ebinop(Oadd, e1, e2), _)) -> + fprintf p "@[%a@,[%a]@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + | Ederef (Expr (Efield(e1, id), _)) -> + fprintf p "%a->%s" print_expr_prec (level, e1) (nameof id) + | Ederef e -> + fprintf p "*%a" print_expr_prec (level, e) + | Eaddrof e -> + fprintf p "&%a" print_expr_prec (level, e) + | Ebinop(op, e1, e2) -> + fprintf p "@[%a@ %s %a@]" + print_expr_prec (level, e1) + (name_binop op) + print_expr_prec (level, e2) + | Ecast(ty, e1) -> + fprintf p "@[(%s)@,%a@]" + (name_type ty) + print_expr_prec (level, e1) + | Econdition(e1, e2, e3) -> + fprintf p "@[%a@ ? %a@ : %a@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + print_expr_prec (level, e3) + | Eandbool(e1, e2) -> + fprintf p "@[%a@ && %a@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + | Eorbool(e1, e2) -> + fprintf p "@[%a@ || %a@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + | Esizeof ty -> + fprintf p "sizeof(%s)" (name_type ty) + | Efield(e1, id) -> + fprintf p "%a.%s" print_expr_prec (level, e1) (nameof id) + | Ecost (lbl,e1) -> + match !style with + | Cost_plain -> + fprintf p "(/* %s */ %a)" (namecost lbl) print_expr e1 + | Cost_numbered (cm,_,_,_) -> + fprintf p "(/* %s = %d */ %a)" (namecost lbl) (int_of_matitanat (cm lbl)) print_expr e1 + | Cost_instrumented (cm,_,_,_) -> + fprintf p "(__cost_incr(%d), %a)" (int_of_matitanat (cm lbl)) print_expr e1 + (*| Ecall (f, arg, e) -> + fprintf p "(%s(%a), %a)" f print_expr arg print_expr e*) + +and print_expr_prec p (context_prec, e) = + let this_prec = parenthesis_level e in + if this_prec >= context_prec + then fprintf p "(%a)" print_expr e + else print_expr p e + +let rec print_expr_list p (first, el) = + match el with + | Extracted.List.Nil -> () + | Extracted.List.Cons (e1, et) -> + if not first then fprintf p ",@ "; + print_expr p e1; + print_expr_list p (false, et) + +(* Another quick hack :( *) +let return_cost = ref None +let print_return_cost p = + match !return_cost with + | None -> () + | Some s -> fprintf p "@ __stack_size_incr(-%d);@ " s + +let rec print_stmt p s = + match s with + | Sskip -> + fprintf p "/*skip*/;" + | Sassign(e1, e2) -> + fprintf p "@[%a =@ %a;@]" print_expr e1 print_expr e2 + | Scall(Extracted.Types.None, e1, el) -> + fprintf p "@[%a@,(@[%a@]);@]" + print_expr e1 + print_expr_list (true, el) + | Scall(Extracted.Types.Some lhs, e1, el) -> + fprintf p "@[%a =@ %a@,(@[%a@]);@]" + print_expr lhs + print_expr e1 + print_expr_list (true, el) + | Ssequence(s1, s2) -> + fprintf p "%a@ %a" print_stmt s1 print_stmt s2 + | Sifthenelse(e, s1, Sskip) -> + fprintf p "@[if (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + | Sifthenelse(e, s1, s2) -> + fprintf p "@[if (%a) {@ %a@;<0 -2>} else {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + print_stmt s2 + | Swhile(e, s) -> + fprintf p "@[while (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s + | Sdowhile(e, s) -> + fprintf p "@[do {@ %a@;<0 -2>} while(%a);@]" + print_stmt s + print_expr e + | Sfor(s_init, e, s_iter, s_body) -> + fprintf p "@[for (@[%a;@ %a;@ %a) {@]@ %a@;<0 -2>}@]" + print_stmt_for s_init + print_expr e + print_stmt_for s_iter + print_stmt s_body + | Sbreak -> + fprintf p "break;" + | Scontinue -> + fprintf p "continue;" + | Sswitch(e, cases) -> + fprintf p "@[switch (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_cases cases + | Sreturn Extracted.Types.None -> + print_return_cost p; + fprintf p "return;" + | Sreturn (Extracted.Types.Some e) -> + print_return_cost p; + fprintf p "return %a;" print_expr e + | Slabel(lbl, s1) -> + fprintf p "%s:@ %a" (nameof lbl) print_stmt s1 + | Sgoto lbl -> + fprintf p "goto %s;" (nameof lbl) + | Scost (lbl,s1) -> + match !style with + | Cost_plain -> + fprintf p "%s:@ %a" (namecost lbl) print_stmt s1 + | Cost_numbered (cm,_,_,_) -> + fprintf p "/* %s = %d */@ %a" (namecost lbl) (int_of_matitanat (cm lbl)) print_stmt s1 + | Cost_instrumented (cm,_,_,_) -> + fprintf p "__cost_incr(%d);@ %a" (int_of_matitanat (cm lbl)) print_stmt s1 + +and print_cases p cases = + match cases with + | LSdefault Sskip -> + () + | LSdefault s -> + fprintf p "@[default:@ %a@]" print_stmt s + | LScase(_, lbl, Sskip, rem) -> + fprintf p "case %ld:@ %a" + (Int32.of_int (int_of_bitvector lbl)) + print_cases rem + | LScase(_, lbl, s, rem) -> + fprintf p "@[case %ld:@ %a@]@ %a" + (Int32.of_int (int_of_bitvector lbl)) + print_stmt s + print_cases rem + +and print_stmt_for p s = + match s with + | Sskip -> + fprintf p "/*nothing*/" + | Sassign(e1, e2) -> + fprintf p "%a = %a" print_expr e1 print_expr e2 + | Ssequence(s1, s2) -> + fprintf p "%a, %a" print_stmt_for s1 print_stmt_for s2 + | Scall(Extracted.Types.None, e1, el) -> + fprintf p "@[%a@,(@[%a@])@]" + print_expr e1 + print_expr_list (true, el) + | Scall(Extracted.Types.Some lhs, e1, el) -> + fprintf p "@[%a =@ %a@,(@[%a@])@]" + print_expr lhs + print_expr e1 + print_expr_list (true, el) + | _ -> + fprintf p "({ %a })" print_stmt s + +let name_function_parameters fun_name params = + let b = Buffer.create 20 in + Buffer.add_string b fun_name; + Buffer.add_char b '('; + begin match params with + | Extracted.List.Nil -> + Buffer.add_string b "void" + | _ -> + let rec add_params first = function + | Extracted.List.Nil -> () + | Extracted.List.Cons ({Extracted.Types.fst = id; Extracted.Types.snd = ty}, rem) -> + if not first then Buffer.add_string b ", "; + Buffer.add_string b (name_cdecl (nameof id) ty); + add_params false rem in + add_params true params + end; + Buffer.add_char b ')'; + Buffer.contents b + +let print_function p id f = + fprintf p "%s@ " + (name_cdecl (name_function_parameters (nameof id) f.fn_params) + f.fn_return); + fprintf p "@[{@ "; + mListIter + (fun ({Extracted.Types.fst = id; Extracted.Types.snd = ty}) -> + fprintf p "%s;@ " (name_cdecl (nameof id) ty)) + f.fn_vars; + (match !style with + | Cost_plain -> return_cost := None + | Cost_numbered (_,_,scm,_) -> + let cost = stack_cost_for scm id in + fprintf p "/* stack cost %d */@ " cost; + return_cost := None (* No need to tell us the stack size again *) + | Cost_instrumented (_,_,scm,_) -> + let cost = stack_cost_for scm id in + fprintf p "__stack_size_incr(%d);@ " cost; + return_cost := Some cost + ); + print_stmt p f.fn_body; + (* We don't always need this (e.g., when it ends with a return), but + better safe than sorry... *) + print_return_cost p; + fprintf p "@;<0 -2>}@]@ @ " + +let print_fundef p {Extracted.Types.fst = id; Extracted.Types.snd = fd} = + match fd with + | CL_External(_, args, res) -> + fprintf p "extern %s;@ @ " + (name_cdecl (nameof id) (Tfunction(args, res))) + | CL_Internal f -> + print_function p id f + +let string_of_init id = + let b = Buffer.create (List.length id) in + let add_init = function + | Init_int8 n -> + let n = int_of_bitvector n in + if n >= 32 && n <= 126 && n <> Char.code '\"' && n <> Char.code '\\' + then Buffer.add_char b (Char.chr n) + else Buffer.add_string b (Printf.sprintf "\\%03o" n) + | _ -> + assert false + in List.iter add_init id; Buffer.contents b + +let eight = matitanat_of_int 8 +let zero8 = Extracted.BitVector.zero eight + +let chop_last_nul id = + match List.rev id with + | Init_int8 n :: tl when Extracted.BitVector.eq_bv eight n zero8 = Extracted.Bool.True -> List.rev tl + | _ -> id + +let print_init p = function + | Init_int8 n -> fprintf p "%ld,@ " (Int32.of_int (int_of_bitvector n)) + | Init_int16 n -> fprintf p "%ld,@ " (Int32.of_int (int_of_bitvector n)) + | Init_int32 n -> fprintf p "%ld,@ " (Int32.of_int (int_of_bitvector n)) + (*| Init_float32 n -> fprintf p "%F,@ " n + | Init_float64 n -> fprintf p "%F,@ " n*) + | Init_space n -> fprintf p "/* skip %ld, */@ " (Int32.of_int (int_of_matitanat n)) + | Init_null -> fprintf p "0,@ " + | Init_addrof(symb, ofs) -> + let symb = nameof symb in + let ofs = Int32.of_int (int_of_matitanat ofs) in + if ofs = Int32.zero + then fprintf p "&%s,@ " symb + else fprintf p "(void *)((char *)&%s + %ld),@ " symb ofs + +let print_init1 p = function + | Init_int8 n -> fprintf p "%ld" (Int32.of_int (int_of_bitvector n)) + | Init_int16 n -> fprintf p "%ld" (Int32.of_int (int_of_bitvector n)) + | Init_int32 n -> fprintf p "%ld" (Int32.of_int (int_of_bitvector n)) + (*| Init_float32 n -> fprintf p "%F" n + | Init_float64 n -> fprintf p "%F" n*) + | Init_space n -> fprintf p "/* skip %ld */" (Int32.of_int (int_of_matitanat n)) + | Init_null -> fprintf p "0" + | Init_addrof(symb, ofs) -> + let symb = nameof symb in + let ofs = Int32.of_int (int_of_matitanat ofs) in + if ofs = Int32.zero + then fprintf p "&%s" symb + else fprintf p "(void *)((char *)&%s + %ld)" symb ofs + +(* XXX From Misc.LexingExt *) + let lex_num s pos = + let rec num i = + if s.[i] >= '0' && s.[i] <= '9' then + num (i + 1) + else + i + in + let pos' = num pos in + if pos = pos' then + None + else + Some (pos, pos', int_of_string (String.sub s pos (pos' - pos))) + + +let match_string_literal s pos = + let s_len = String.length s - 1 in + let prefix = "__stringlit_" in + let len_prefix = String.length prefix in + s_len >= len_prefix + && String.sub s 0 len_prefix = prefix && + match lex_num s len_prefix with + | None -> false + | Some (pos, pos', v) -> pos' = String.length s - 1 + +let print_globvar p ({Extracted.Types.fst = + {Extracted.Types.fst = id; Extracted.Types.snd = region}; + Extracted.Types.snd = + {Extracted.Types.fst = init; Extracted.Types.snd = ty}; + }) = + let id = nameof id in + let init = mlist init in + match init with + | [] -> + fprintf p "extern %s;@ @ " + (name_cdecl id ty) + | [Init_space _] -> + fprintf p "%s;@ @ " + (name_cdecl id ty) + | [init] -> + fprintf p "@[%s = %a;@]@ @ " + (name_cdecl id ty) print_init1 init + | _ -> + fprintf p "@[%s = " + (name_cdecl id ty); + if match_string_literal id 0 + && List.for_all (function Init_int8 _ -> true | _ -> false) init + then + fprintf p "\"%s\"" (string_of_init (chop_last_nul init)) + else begin + fprintf p "{@ "; + List.iter (print_init p) init; + fprintf p "}" + end; + fprintf p ";@]@ @ " + +(* Collect struct and union types *) + +let rec collect_type = function + | Tvoid -> () + | Tint(sz, sg) -> () + (*| Tfloat sz -> ()*) + | Tpointer t -> collect_type t + | Tarray(t, n) -> collect_type t + | Tfunction(args, res) -> collect_type_list args; collect_type res + | Tstruct(id, fld) -> register_struct_union (nameof id) fld; collect_fields fld + | Tunion(id, fld) -> register_struct_union (nameof id) fld; collect_fields fld + | Tcomp_ptr _ -> () + +and collect_type_list = function + | Tnil -> () + | Tcons (hd,tl) -> collect_type hd; collect_type_list tl + +and collect_fields = function + | Fnil -> () + | Fcons (id, hd, tl) -> collect_type hd; collect_fields tl + +let rec collect_expr (Expr(ed, ty)) = + match ed with + | Econst_int _ -> () + (*| Econst_float f -> ()*) + | Evar id -> () + | Eunop(op, e1) -> collect_expr e1 + | Ederef e -> collect_expr e + | Eaddrof e -> collect_expr e + | Ebinop(op, e1, e2) -> collect_expr e1; collect_expr e2 + | Ecast(ty, e1) -> collect_type ty; collect_expr e1 + | Econdition(e1, e2, e3) -> collect_expr e1; collect_expr e2; collect_expr e3 + | Eandbool(e1, e2) -> collect_expr e1; collect_expr e2 + | Eorbool(e1, e2) -> collect_expr e1; collect_expr e2 + | Esizeof ty -> collect_type ty + | Efield(e1, id) -> collect_expr e1 + | Ecost(_, e) -> collect_expr e + (*| Ecall(_, arg, e) -> collect_expr arg; collect_expr e*) + +let rec collect_expr_list = function + | Extracted.List.Nil -> () + | Extracted.List.Cons (hd, tl) -> collect_expr hd; collect_expr_list tl + +let rec collect_stmt = function + | Sskip -> () + | Sassign(e1, e2) -> collect_expr e1; collect_expr e2 + | Scall(Extracted.Types.None, e1, el) -> collect_expr e1; collect_expr_list el + | Scall(Extracted.Types.Some lhs, e1, el) -> collect_expr lhs; collect_expr e1; collect_expr_list el + | Ssequence(s1, s2) -> collect_stmt s1; collect_stmt s2 + | Sifthenelse(e, s1, s2) -> collect_expr e; collect_stmt s1; collect_stmt s2 + | Swhile(e, s) -> collect_expr e; collect_stmt s + | Sdowhile(e, s) -> collect_stmt s; collect_expr e + | Sfor(s_init, e, s_iter, s_body) -> + collect_stmt s_init; collect_expr e; + collect_stmt s_iter; collect_stmt s_body + | Sbreak -> () + | Scontinue -> () + | Sswitch(e, cases) -> collect_expr e; collect_cases cases + | Sreturn Extracted.Types.None -> () + | Sreturn (Extracted.Types.Some e) -> collect_expr e + | Slabel(lbl, s) -> collect_stmt s + | Sgoto lbl -> () + | Scost (_,s1) -> collect_stmt s1 + +and collect_cases = function + | LSdefault s -> collect_stmt s + | LScase(_, lbl, s, rem) -> collect_stmt s; collect_cases rem + +let collect_function f = + collect_type f.fn_return; + mListIter (fun ({Extracted.Types.fst = id; Extracted.Types.snd = ty}) -> collect_type ty) f.fn_params; + mListIter (fun ({Extracted.Types.fst = id; Extracted.Types.snd = ty}) -> collect_type ty) f.fn_vars; + collect_stmt f.fn_body + +let collect_fundef ({Extracted.Types.fst = id; Extracted.Types.snd = fd}) = + match fd with + | CL_External(_, args, res) -> collect_type_list args; collect_type res + | CL_Internal f -> collect_function f + +let collect_globvar v = + collect_type (Extracted.Types.snd (Extracted.Types.snd v)) + +let collect_program p = + mListIter collect_globvar p.prog_vars; + mListIter collect_fundef p.prog_funct + +let declare_struct_or_union p (name, fld) = + fprintf p "%s;@ @ " name + +let print_struct_or_union p (name, fld) = + fprintf p "@[%s {" name; + let rec print_fields = function + | Fnil -> () + | Fcons (id, ty, rem) -> + fprintf p "@ %s;" (name_cdecl (nameof id) ty); + print_fields rem in + print_fields fld; + fprintf p "@;<0 -2>};@]@ " + +let print_program_2 p prog = + struct_unions := StructUnionSet.empty; + collect_program prog; + fprintf p "@["; + StructUnionSet.iter (declare_struct_or_union p) !struct_unions; + StructUnionSet.iter (print_struct_or_union p) !struct_unions; + mListIter (print_globvar p) prog.prog_vars; + mListIter (print_fundef p) prog.prog_funct; + fprintf p "@]@." + +let print_program cs prog = + style := cs; + (match cs with + | Cost_instrumented (cm,initc,_,sinit) -> + let cinit = int_of_matitanat (cm initc) in + let sinit = int_of_float (2.0 ** 16.) - int_of_matitanat sinit in + fprintf str_formatter "int __cost = %d;@\n@\n" cinit; + fprintf str_formatter "int __stack_size = %d, __stack_size_max = %d;@\n@\n" sinit sinit; + fprintf str_formatter "void __cost_incr(int incr) {@\n"; + fprintf str_formatter " __cost = __cost + incr;@\n}@\n@\n"; + fprintf str_formatter "void __stack_size_incr(int incr) {@\n"; + fprintf str_formatter " __stack_size = __stack_size + incr;@\n"; + fprintf str_formatter " __stack_size_max = __stack_size_max < __stack_size ? __stack_size : __stack_size_max;@\n}@\n@\n" + | _ -> ()); + print_program_2 str_formatter prog; + flush_str_formatter () + +let string_of_ctype = name_type + +let print_expression cs e = + style := cs; + print_expr str_formatter e; + flush_str_formatter () + +let print_statement cs s = + style := cs; + print_stmt str_formatter s; + flush_str_formatter () + +let print_ctype_prot = name_type + +let print_ctype_def = function + | Tstruct (name, fld) | Tunion (name, fld) -> + let f_fld s (id, t) = s ^ " " ^ (print_ctype_prot t) ^ " " ^ id ^ ";\n" in + let s_fld = List.fold_left f_fld "" in + nameof name ^ " {\n" ^ (s_fld (flist fld)) ^ "};\n" + | _ -> "" (* no definition associated to the other types *) + +let string_of_unop = name_unop + +let string_of_binop = name_binop diff --git a/clightPrinter.mli b/clightPrinter.mli new file mode 100644 index 0000000..b765c25 --- /dev/null +++ b/clightPrinter.mli @@ -0,0 +1,23 @@ +(** This module provides functions to print elements of [Extracted.Csyntax] + programs. *) + +type cost_style = +| Cost_plain +| Cost_numbered of Extracted.Label.clight_cost_map * Extracted.Joint.stack_cost_model +| Cost_instrumented of Extracted.Label.clight_cost_map * Extracted.Joint.stack_cost_model + +val print_program: cost_style -> Extracted.Csyntax.clight_program -> string + +val print_expression: cost_style -> Extracted.Csyntax.expr -> string + +val string_of_ctype: Extracted.Csyntax.type0 -> string + +val print_statement: cost_style -> Extracted.Csyntax.statement -> string + +val print_ctype_prot: Extracted.Csyntax.type0 -> string + +val print_ctype_def: Extracted.Csyntax.type0 -> string + +val string_of_unop : Extracted.Csyntax.unary_operation -> string + +val string_of_binop : Extracted.Csyntax.binary_operation -> string diff --git a/error.ml b/error.ml new file mode 100644 index 0000000..4a263d8 --- /dev/null +++ b/error.ml @@ -0,0 +1,94 @@ +open Extracted.Errors +open Extracted.ErrorMessages + +let error_to_string = function +| NotTerminated -> "NotTerminated" +| AssemblyTooLarge -> "AssemblyTooLarge" +| MISSING -> "MISSING" +| EXTERNAL -> "EXTERNAL" +| Jump_expansion_failed +| ValueIsNotABoolean -> "ValueIsNotABoolean" +| BadCast -> "BadCast" +| BadlyTypedTerm -> "BadlyTypedTerm" +| UnknownIdentifier -> "UnknownIdentifier" +| BadLvalueTerm -> "BadLvalueTerm" +| FailedLoad -> "FailedLoad" +| FailedOp -> "FailedOp" +| WrongNumberOfParameters -> "WrongNumberOfParameters" +| FailedStore -> "FailedStore" +| NonsenseState -> "NonsenseState" +| ReturnMismatch -> "ReturnMismatch" +| UnknownLabel -> "UnknownLabel" +| BadFunctionValue -> "BadFunctionValue" +| MainMissing -> "MainMissing" +| UnknownField -> "UnknownField" +| UndeclaredIdentifier -> "UndeclaredIdentifier" +| BadlyTypedAccess -> "BadlyTypedAccess" +| BadLvalue -> "BadLvalue" +| MissingField -> "MissingField" +| FIXME -> "FIXME" +| MissingLabel -> "MissingLabel" +| ParamGlobalMixup -> "ParamGlobalMixup" +| DuplicateLabel -> "DuplicateLabel" +| TypeMismatch -> "TypeMismatch" +| UnknownLocal -> "UnknownLocal" +| FailedConstant -> "FailedConstant" +| BadState -> "BadState" +| StoppedMidIO -> "StoppedMidIO" +| UnsupportedOp -> "UnsupportedOp" +| CorruptedPointer -> "CorruptedPointer" +| NotATwoBytesPointer -> "NotATwoBytesPointer" +| ValueNotABoolean -> "ValueNotABoolean" +| NotAnInt32Val +| WrongLength -> "WrongLength" +| InitDataStoreFailed -> "InitDataStoreFailed" +| DuplicateVariable -> "DuplicateVariable" +| MissingId -> "MissingId" +| IllTypedEvent -> "IllTypedEvent" +| InternalStackFull -> "InternalStackFull" +| InternalStackEmpty -> "InternalStackEmpty" +| BadProgramCounter -> "BadProgramCounter" +| ProgramCounterOutOfCode -> "ProgramCounterOutOfCode" +| PointNotFound -> "PointNotFound" +| LabelNotFound -> "LabelNotFound" +| MissingSymbol -> "MissingSymbol" +| BadFunction -> "BadFunction" +| SuccessorNotProvided -> "SuccessorNotProvided" +| BadPointer -> "BadPointer" +| NoSuccessor -> "NoSuccessor" +| MissingStackSize -> "MissingStackSize" +| ExternalMain -> "ExternalMain" +| BadRegister -> "BadRegister" +| BadMain -> "BadMain" +| MissingRegister -> "MissingRegister" +| MissingStatement -> "MissingStatement" +| BadJumpTable -> "BadJumpTable" +| BadJumpValue -> "BadJumpValue" +| FinalState -> "FinalState" +| EmptyStack -> "EmptyStack" +| OutOfBounds -> "OutOfBounds" +| UnexpectedIO -> "UnexpectedIO" +| TerminatedEarly -> "TerminatedEarly" +| RepeatedCostLabel -> "RepeatedCostLabel" +| BadCostLabelling -> "BadCostLabelling" +| FunctionNotFound -> "FunctionNotFound" +| FrameErrorOnPop -> "FrameErrorOnPop" +| FrameErrorOnPush -> "FrameErrorOnPush" +| BlockInFramesCorrupted -> "BlockInFramesCorrupted" +| FramesEmptyOnPop -> "FramesEmptyOnPop" +| RepeatedCostLabel0 -> "RepeatedCostLabel0" +| StackOverflow -> "StackOverflow" + + + +let rec conv_list l = +(match l with +| Extracted.List.Nil -> [ ] +| Extracted.List.Cons (h, t) -> h::conv_list t) + +let errormsg m = + String.concat " " + (conv_list + (Extracted.List.map + (function Extracted.Errors.MSG e -> error_to_string e | _ -> "") + m)) diff --git a/extracted/MODIFIED_BY_HAND b/extracted/MODIFIED_BY_HAND new file mode 100644 index 0000000..2cfefb3 --- /dev/null +++ b/extracted/MODIFIED_BY_HAND @@ -0,0 +1,3 @@ +1. policy.ma +2. compiler.ma +3. aSMCostsSplit.ma diff --git a/extracted/PROBLEMS b/extracted/PROBLEMS new file mode 100644 index 0000000..32526c0 --- /dev/null +++ b/extracted/PROBLEMS @@ -0,0 +1,17 @@ +========================= +EXTRACTION BUGS: +========================= + +New bug: some function has type "__ foo" in the .ml and "'a foo" in the .mli. +The latter is incorrect. + +========================= +AXIOMS TO BE IMPLEMENTED: +========================= + +In order to plug the untrusted code, the following files needs manual +intervention: + +a) compiler.ml: the two failwith must be replaced with calls to the + untrusted code +b) the build script removed set_adt to favour the untrusted implementation diff --git a/extracted/aSM.ml b/extracted/aSM.ml new file mode 100644 index 0000000..e7665c5 --- /dev/null +++ b/extracted/aSM.ml @@ -0,0 +1,6090 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open LabelledObjects + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open String + +open BitVectorTrie + +type identifier = PreIdentifiers.identifier + +(** val toASM_ident : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> identifier **) +let toASM_ident t i = + let id = i in id + +type addressing_mode = +| DIRECT of BitVector.byte +| INDIRECT of BitVector.bit +| EXT_INDIRECT of BitVector.bit +| REGISTER of BitVector.bitVector +| ACC_A +| ACC_B +| DPTR +| DATA of BitVector.byte +| DATA16 of BitVector.word +| ACC_DPTR +| ACC_PC +| EXT_INDIRECT_DPTR +| INDIRECT_DPTR +| CARRY +| BIT_ADDR of BitVector.byte +| N_BIT_ADDR of BitVector.byte +| RELATIVE of BitVector.byte +| ADDR11 of BitVector.word11 +| ADDR16 of BitVector.word + +(** val addressing_mode_rect_Type4 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> + 'a1) -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> + (BitVector.byte -> 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word + -> 'a1) -> addressing_mode -> 'a1 **) +let rec addressing_mode_rect_Type4 h_DIRECT h_INDIRECT h_EXT_INDIRECT h_REGISTER h_ACC_A h_ACC_B h_DPTR h_DATA h_DATA16 h_ACC_DPTR h_ACC_PC h_EXT_INDIRECT_DPTR h_INDIRECT_DPTR h_CARRY h_BIT_ADDR h_N_BIT_ADDR h_RELATIVE h_ADDR11 h_ADDR16 = function +| DIRECT x_19160 -> h_DIRECT x_19160 +| INDIRECT x_19161 -> h_INDIRECT x_19161 +| EXT_INDIRECT x_19162 -> h_EXT_INDIRECT x_19162 +| REGISTER x_19163 -> h_REGISTER x_19163 +| ACC_A -> h_ACC_A +| ACC_B -> h_ACC_B +| DPTR -> h_DPTR +| DATA x_19164 -> h_DATA x_19164 +| DATA16 x_19165 -> h_DATA16 x_19165 +| ACC_DPTR -> h_ACC_DPTR +| ACC_PC -> h_ACC_PC +| EXT_INDIRECT_DPTR -> h_EXT_INDIRECT_DPTR +| INDIRECT_DPTR -> h_INDIRECT_DPTR +| CARRY -> h_CARRY +| BIT_ADDR x_19166 -> h_BIT_ADDR x_19166 +| N_BIT_ADDR x_19167 -> h_N_BIT_ADDR x_19167 +| RELATIVE x_19168 -> h_RELATIVE x_19168 +| ADDR11 x_19169 -> h_ADDR11 x_19169 +| ADDR16 x_19170 -> h_ADDR16 x_19170 + +(** val addressing_mode_rect_Type5 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> + 'a1) -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> + (BitVector.byte -> 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word + -> 'a1) -> addressing_mode -> 'a1 **) +let rec addressing_mode_rect_Type5 h_DIRECT h_INDIRECT h_EXT_INDIRECT h_REGISTER h_ACC_A h_ACC_B h_DPTR h_DATA h_DATA16 h_ACC_DPTR h_ACC_PC h_EXT_INDIRECT_DPTR h_INDIRECT_DPTR h_CARRY h_BIT_ADDR h_N_BIT_ADDR h_RELATIVE h_ADDR11 h_ADDR16 = function +| DIRECT x_19191 -> h_DIRECT x_19191 +| INDIRECT x_19192 -> h_INDIRECT x_19192 +| EXT_INDIRECT x_19193 -> h_EXT_INDIRECT x_19193 +| REGISTER x_19194 -> h_REGISTER x_19194 +| ACC_A -> h_ACC_A +| ACC_B -> h_ACC_B +| DPTR -> h_DPTR +| DATA x_19195 -> h_DATA x_19195 +| DATA16 x_19196 -> h_DATA16 x_19196 +| ACC_DPTR -> h_ACC_DPTR +| ACC_PC -> h_ACC_PC +| EXT_INDIRECT_DPTR -> h_EXT_INDIRECT_DPTR +| INDIRECT_DPTR -> h_INDIRECT_DPTR +| CARRY -> h_CARRY +| BIT_ADDR x_19197 -> h_BIT_ADDR x_19197 +| N_BIT_ADDR x_19198 -> h_N_BIT_ADDR x_19198 +| RELATIVE x_19199 -> h_RELATIVE x_19199 +| ADDR11 x_19200 -> h_ADDR11 x_19200 +| ADDR16 x_19201 -> h_ADDR16 x_19201 + +(** val addressing_mode_rect_Type3 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> + 'a1) -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> + (BitVector.byte -> 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word + -> 'a1) -> addressing_mode -> 'a1 **) +let rec addressing_mode_rect_Type3 h_DIRECT h_INDIRECT h_EXT_INDIRECT h_REGISTER h_ACC_A h_ACC_B h_DPTR h_DATA h_DATA16 h_ACC_DPTR h_ACC_PC h_EXT_INDIRECT_DPTR h_INDIRECT_DPTR h_CARRY h_BIT_ADDR h_N_BIT_ADDR h_RELATIVE h_ADDR11 h_ADDR16 = function +| DIRECT x_19222 -> h_DIRECT x_19222 +| INDIRECT x_19223 -> h_INDIRECT x_19223 +| EXT_INDIRECT x_19224 -> h_EXT_INDIRECT x_19224 +| REGISTER x_19225 -> h_REGISTER x_19225 +| ACC_A -> h_ACC_A +| ACC_B -> h_ACC_B +| DPTR -> h_DPTR +| DATA x_19226 -> h_DATA x_19226 +| DATA16 x_19227 -> h_DATA16 x_19227 +| ACC_DPTR -> h_ACC_DPTR +| ACC_PC -> h_ACC_PC +| EXT_INDIRECT_DPTR -> h_EXT_INDIRECT_DPTR +| INDIRECT_DPTR -> h_INDIRECT_DPTR +| CARRY -> h_CARRY +| BIT_ADDR x_19228 -> h_BIT_ADDR x_19228 +| N_BIT_ADDR x_19229 -> h_N_BIT_ADDR x_19229 +| RELATIVE x_19230 -> h_RELATIVE x_19230 +| ADDR11 x_19231 -> h_ADDR11 x_19231 +| ADDR16 x_19232 -> h_ADDR16 x_19232 + +(** val addressing_mode_rect_Type2 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> + 'a1) -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> + (BitVector.byte -> 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word + -> 'a1) -> addressing_mode -> 'a1 **) +let rec addressing_mode_rect_Type2 h_DIRECT h_INDIRECT h_EXT_INDIRECT h_REGISTER h_ACC_A h_ACC_B h_DPTR h_DATA h_DATA16 h_ACC_DPTR h_ACC_PC h_EXT_INDIRECT_DPTR h_INDIRECT_DPTR h_CARRY h_BIT_ADDR h_N_BIT_ADDR h_RELATIVE h_ADDR11 h_ADDR16 = function +| DIRECT x_19253 -> h_DIRECT x_19253 +| INDIRECT x_19254 -> h_INDIRECT x_19254 +| EXT_INDIRECT x_19255 -> h_EXT_INDIRECT x_19255 +| REGISTER x_19256 -> h_REGISTER x_19256 +| ACC_A -> h_ACC_A +| ACC_B -> h_ACC_B +| DPTR -> h_DPTR +| DATA x_19257 -> h_DATA x_19257 +| DATA16 x_19258 -> h_DATA16 x_19258 +| ACC_DPTR -> h_ACC_DPTR +| ACC_PC -> h_ACC_PC +| EXT_INDIRECT_DPTR -> h_EXT_INDIRECT_DPTR +| INDIRECT_DPTR -> h_INDIRECT_DPTR +| CARRY -> h_CARRY +| BIT_ADDR x_19259 -> h_BIT_ADDR x_19259 +| N_BIT_ADDR x_19260 -> h_N_BIT_ADDR x_19260 +| RELATIVE x_19261 -> h_RELATIVE x_19261 +| ADDR11 x_19262 -> h_ADDR11 x_19262 +| ADDR16 x_19263 -> h_ADDR16 x_19263 + +(** val addressing_mode_rect_Type1 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> + 'a1) -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> + (BitVector.byte -> 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word + -> 'a1) -> addressing_mode -> 'a1 **) +let rec addressing_mode_rect_Type1 h_DIRECT h_INDIRECT h_EXT_INDIRECT h_REGISTER h_ACC_A h_ACC_B h_DPTR h_DATA h_DATA16 h_ACC_DPTR h_ACC_PC h_EXT_INDIRECT_DPTR h_INDIRECT_DPTR h_CARRY h_BIT_ADDR h_N_BIT_ADDR h_RELATIVE h_ADDR11 h_ADDR16 = function +| DIRECT x_19284 -> h_DIRECT x_19284 +| INDIRECT x_19285 -> h_INDIRECT x_19285 +| EXT_INDIRECT x_19286 -> h_EXT_INDIRECT x_19286 +| REGISTER x_19287 -> h_REGISTER x_19287 +| ACC_A -> h_ACC_A +| ACC_B -> h_ACC_B +| DPTR -> h_DPTR +| DATA x_19288 -> h_DATA x_19288 +| DATA16 x_19289 -> h_DATA16 x_19289 +| ACC_DPTR -> h_ACC_DPTR +| ACC_PC -> h_ACC_PC +| EXT_INDIRECT_DPTR -> h_EXT_INDIRECT_DPTR +| INDIRECT_DPTR -> h_INDIRECT_DPTR +| CARRY -> h_CARRY +| BIT_ADDR x_19290 -> h_BIT_ADDR x_19290 +| N_BIT_ADDR x_19291 -> h_N_BIT_ADDR x_19291 +| RELATIVE x_19292 -> h_RELATIVE x_19292 +| ADDR11 x_19293 -> h_ADDR11 x_19293 +| ADDR16 x_19294 -> h_ADDR16 x_19294 + +(** val addressing_mode_rect_Type0 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> + 'a1) -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> + (BitVector.byte -> 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word + -> 'a1) -> addressing_mode -> 'a1 **) +let rec addressing_mode_rect_Type0 h_DIRECT h_INDIRECT h_EXT_INDIRECT h_REGISTER h_ACC_A h_ACC_B h_DPTR h_DATA h_DATA16 h_ACC_DPTR h_ACC_PC h_EXT_INDIRECT_DPTR h_INDIRECT_DPTR h_CARRY h_BIT_ADDR h_N_BIT_ADDR h_RELATIVE h_ADDR11 h_ADDR16 = function +| DIRECT x_19315 -> h_DIRECT x_19315 +| INDIRECT x_19316 -> h_INDIRECT x_19316 +| EXT_INDIRECT x_19317 -> h_EXT_INDIRECT x_19317 +| REGISTER x_19318 -> h_REGISTER x_19318 +| ACC_A -> h_ACC_A +| ACC_B -> h_ACC_B +| DPTR -> h_DPTR +| DATA x_19319 -> h_DATA x_19319 +| DATA16 x_19320 -> h_DATA16 x_19320 +| ACC_DPTR -> h_ACC_DPTR +| ACC_PC -> h_ACC_PC +| EXT_INDIRECT_DPTR -> h_EXT_INDIRECT_DPTR +| INDIRECT_DPTR -> h_INDIRECT_DPTR +| CARRY -> h_CARRY +| BIT_ADDR x_19321 -> h_BIT_ADDR x_19321 +| N_BIT_ADDR x_19322 -> h_N_BIT_ADDR x_19322 +| RELATIVE x_19323 -> h_RELATIVE x_19323 +| ADDR11 x_19324 -> h_ADDR11 x_19324 +| ADDR16 x_19325 -> h_ADDR16 x_19325 + +(** val addressing_mode_inv_rect_Type4 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ + -> 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 **) +let addressing_mode_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_inv_rect_Type3 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ + -> 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 **) +let addressing_mode_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_inv_rect_Type2 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ + -> 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 **) +let addressing_mode_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_inv_rect_Type1 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ + -> 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 **) +let addressing_mode_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_inv_rect_Type0 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ + -> 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 **) +let addressing_mode_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_discr : addressing_mode -> addressing_mode -> __ **) +let addressing_mode_discr x y = + Logic.eq_rect_Type2 x + (match x with + | DIRECT a0 -> Obj.magic (fun _ dH -> dH __) + | INDIRECT a0 -> Obj.magic (fun _ dH -> dH __) + | EXT_INDIRECT a0 -> Obj.magic (fun _ dH -> dH __) + | REGISTER a0 -> Obj.magic (fun _ dH -> dH __) + | ACC_A -> Obj.magic (fun _ dH -> dH) + | ACC_B -> Obj.magic (fun _ dH -> dH) + | DPTR -> Obj.magic (fun _ dH -> dH) + | DATA a0 -> Obj.magic (fun _ dH -> dH __) + | DATA16 a0 -> Obj.magic (fun _ dH -> dH __) + | ACC_DPTR -> Obj.magic (fun _ dH -> dH) + | ACC_PC -> Obj.magic (fun _ dH -> dH) + | EXT_INDIRECT_DPTR -> Obj.magic (fun _ dH -> dH) + | INDIRECT_DPTR -> Obj.magic (fun _ dH -> dH) + | CARRY -> Obj.magic (fun _ dH -> dH) + | BIT_ADDR a0 -> Obj.magic (fun _ dH -> dH __) + | N_BIT_ADDR a0 -> Obj.magic (fun _ dH -> dH __) + | RELATIVE a0 -> Obj.magic (fun _ dH -> dH __) + | ADDR11 a0 -> Obj.magic (fun _ dH -> dH __) + | ADDR16 a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val addressing_mode_jmdiscr : + addressing_mode -> addressing_mode -> __ **) +let addressing_mode_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | DIRECT a0 -> Obj.magic (fun _ dH -> dH __) + | INDIRECT a0 -> Obj.magic (fun _ dH -> dH __) + | EXT_INDIRECT a0 -> Obj.magic (fun _ dH -> dH __) + | REGISTER a0 -> Obj.magic (fun _ dH -> dH __) + | ACC_A -> Obj.magic (fun _ dH -> dH) + | ACC_B -> Obj.magic (fun _ dH -> dH) + | DPTR -> Obj.magic (fun _ dH -> dH) + | DATA a0 -> Obj.magic (fun _ dH -> dH __) + | DATA16 a0 -> Obj.magic (fun _ dH -> dH __) + | ACC_DPTR -> Obj.magic (fun _ dH -> dH) + | ACC_PC -> Obj.magic (fun _ dH -> dH) + | EXT_INDIRECT_DPTR -> Obj.magic (fun _ dH -> dH) + | INDIRECT_DPTR -> Obj.magic (fun _ dH -> dH) + | CARRY -> Obj.magic (fun _ dH -> dH) + | BIT_ADDR a0 -> Obj.magic (fun _ dH -> dH __) + | N_BIT_ADDR a0 -> Obj.magic (fun _ dH -> dH __) + | RELATIVE a0 -> Obj.magic (fun _ dH -> dH __) + | ADDR11 a0 -> Obj.magic (fun _ dH -> dH __) + | ADDR16 a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val eq_addressing_mode : + addressing_mode -> addressing_mode -> Bool.bool **) +let eq_addressing_mode a b = + match a with + | DIRECT d -> + (match b with + | DIRECT e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) d e + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | INDIRECT b' -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT e -> BitVector.eq_b b' e + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | EXT_INDIRECT b' -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT e -> BitVector.eq_b b' e + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | REGISTER bv -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER bv' -> BitVector.eq_bv (Nat.S (Nat.S (Nat.S Nat.O))) bv bv' + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | ACC_A -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.True + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | ACC_B -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.True + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | DPTR -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.True + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | DATA b' -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) b' e + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | DATA16 w -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) w e + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | ACC_DPTR -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.True + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | ACC_PC -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.True + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | EXT_INDIRECT_DPTR -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.True + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | INDIRECT_DPTR -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.True + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | CARRY -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.True + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | BIT_ADDR b' -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) b' e + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | N_BIT_ADDR b' -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) b' e + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | RELATIVE n -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) n e + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | ADDR11 w -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))) w e + | ADDR16 x -> Bool.False) + | ADDR16 w -> + (match b with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 e -> + BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) w e) + +type addressing_mode_tag = +| Direct +| Indirect +| Ext_indirect +| Registr +| Acc_a +| Acc_b +| Dptr +| Data +| Data16 +| Acc_dptr +| Acc_pc +| Ext_indirect_dptr +| Indirect_dptr +| Carry +| Bit_addr +| N_bit_addr +| Relative +| Addr11 +| Addr16 + +(** val addressing_mode_tag_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 **) +let rec addressing_mode_tag_rect_Type4 h_direct h_indirect h_ext_indirect h_registr h_acc_a h_acc_b h_dptr h_data h_data16 h_acc_dptr h_acc_pc h_ext_indirect_dptr h_indirect_dptr h_carry h_bit_addr h_n_bit_addr h_relative h_addr11 h_addr16 = function +| Direct -> h_direct +| Indirect -> h_indirect +| Ext_indirect -> h_ext_indirect +| Registr -> h_registr +| Acc_a -> h_acc_a +| Acc_b -> h_acc_b +| Dptr -> h_dptr +| Data -> h_data +| Data16 -> h_data16 +| Acc_dptr -> h_acc_dptr +| Acc_pc -> h_acc_pc +| Ext_indirect_dptr -> h_ext_indirect_dptr +| Indirect_dptr -> h_indirect_dptr +| Carry -> h_carry +| Bit_addr -> h_bit_addr +| N_bit_addr -> h_n_bit_addr +| Relative -> h_relative +| Addr11 -> h_addr11 +| Addr16 -> h_addr16 + +(** val addressing_mode_tag_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 **) +let rec addressing_mode_tag_rect_Type5 h_direct h_indirect h_ext_indirect h_registr h_acc_a h_acc_b h_dptr h_data h_data16 h_acc_dptr h_acc_pc h_ext_indirect_dptr h_indirect_dptr h_carry h_bit_addr h_n_bit_addr h_relative h_addr11 h_addr16 = function +| Direct -> h_direct +| Indirect -> h_indirect +| Ext_indirect -> h_ext_indirect +| Registr -> h_registr +| Acc_a -> h_acc_a +| Acc_b -> h_acc_b +| Dptr -> h_dptr +| Data -> h_data +| Data16 -> h_data16 +| Acc_dptr -> h_acc_dptr +| Acc_pc -> h_acc_pc +| Ext_indirect_dptr -> h_ext_indirect_dptr +| Indirect_dptr -> h_indirect_dptr +| Carry -> h_carry +| Bit_addr -> h_bit_addr +| N_bit_addr -> h_n_bit_addr +| Relative -> h_relative +| Addr11 -> h_addr11 +| Addr16 -> h_addr16 + +(** val addressing_mode_tag_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 **) +let rec addressing_mode_tag_rect_Type3 h_direct h_indirect h_ext_indirect h_registr h_acc_a h_acc_b h_dptr h_data h_data16 h_acc_dptr h_acc_pc h_ext_indirect_dptr h_indirect_dptr h_carry h_bit_addr h_n_bit_addr h_relative h_addr11 h_addr16 = function +| Direct -> h_direct +| Indirect -> h_indirect +| Ext_indirect -> h_ext_indirect +| Registr -> h_registr +| Acc_a -> h_acc_a +| Acc_b -> h_acc_b +| Dptr -> h_dptr +| Data -> h_data +| Data16 -> h_data16 +| Acc_dptr -> h_acc_dptr +| Acc_pc -> h_acc_pc +| Ext_indirect_dptr -> h_ext_indirect_dptr +| Indirect_dptr -> h_indirect_dptr +| Carry -> h_carry +| Bit_addr -> h_bit_addr +| N_bit_addr -> h_n_bit_addr +| Relative -> h_relative +| Addr11 -> h_addr11 +| Addr16 -> h_addr16 + +(** val addressing_mode_tag_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 **) +let rec addressing_mode_tag_rect_Type2 h_direct h_indirect h_ext_indirect h_registr h_acc_a h_acc_b h_dptr h_data h_data16 h_acc_dptr h_acc_pc h_ext_indirect_dptr h_indirect_dptr h_carry h_bit_addr h_n_bit_addr h_relative h_addr11 h_addr16 = function +| Direct -> h_direct +| Indirect -> h_indirect +| Ext_indirect -> h_ext_indirect +| Registr -> h_registr +| Acc_a -> h_acc_a +| Acc_b -> h_acc_b +| Dptr -> h_dptr +| Data -> h_data +| Data16 -> h_data16 +| Acc_dptr -> h_acc_dptr +| Acc_pc -> h_acc_pc +| Ext_indirect_dptr -> h_ext_indirect_dptr +| Indirect_dptr -> h_indirect_dptr +| Carry -> h_carry +| Bit_addr -> h_bit_addr +| N_bit_addr -> h_n_bit_addr +| Relative -> h_relative +| Addr11 -> h_addr11 +| Addr16 -> h_addr16 + +(** val addressing_mode_tag_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 **) +let rec addressing_mode_tag_rect_Type1 h_direct h_indirect h_ext_indirect h_registr h_acc_a h_acc_b h_dptr h_data h_data16 h_acc_dptr h_acc_pc h_ext_indirect_dptr h_indirect_dptr h_carry h_bit_addr h_n_bit_addr h_relative h_addr11 h_addr16 = function +| Direct -> h_direct +| Indirect -> h_indirect +| Ext_indirect -> h_ext_indirect +| Registr -> h_registr +| Acc_a -> h_acc_a +| Acc_b -> h_acc_b +| Dptr -> h_dptr +| Data -> h_data +| Data16 -> h_data16 +| Acc_dptr -> h_acc_dptr +| Acc_pc -> h_acc_pc +| Ext_indirect_dptr -> h_ext_indirect_dptr +| Indirect_dptr -> h_indirect_dptr +| Carry -> h_carry +| Bit_addr -> h_bit_addr +| N_bit_addr -> h_n_bit_addr +| Relative -> h_relative +| Addr11 -> h_addr11 +| Addr16 -> h_addr16 + +(** val addressing_mode_tag_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 **) +let rec addressing_mode_tag_rect_Type0 h_direct h_indirect h_ext_indirect h_registr h_acc_a h_acc_b h_dptr h_data h_data16 h_acc_dptr h_acc_pc h_ext_indirect_dptr h_indirect_dptr h_carry h_bit_addr h_n_bit_addr h_relative h_addr11 h_addr16 = function +| Direct -> h_direct +| Indirect -> h_indirect +| Ext_indirect -> h_ext_indirect +| Registr -> h_registr +| Acc_a -> h_acc_a +| Acc_b -> h_acc_b +| Dptr -> h_dptr +| Data -> h_data +| Data16 -> h_data16 +| Acc_dptr -> h_acc_dptr +| Acc_pc -> h_acc_pc +| Ext_indirect_dptr -> h_ext_indirect_dptr +| Indirect_dptr -> h_indirect_dptr +| Carry -> h_carry +| Bit_addr -> h_bit_addr +| N_bit_addr -> h_n_bit_addr +| Relative -> h_relative +| Addr11 -> h_addr11 +| Addr16 -> h_addr16 + +(** val addressing_mode_tag_inv_rect_Type4 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let addressing_mode_tag_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_tag_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_tag_inv_rect_Type3 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let addressing_mode_tag_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_tag_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_tag_inv_rect_Type2 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let addressing_mode_tag_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_tag_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_tag_inv_rect_Type1 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let addressing_mode_tag_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_tag_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_tag_inv_rect_Type0 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let addressing_mode_tag_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + addressing_mode_tag_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 hterm + in + hcut __ + +(** val addressing_mode_tag_discr : + addressing_mode_tag -> addressing_mode_tag -> __ **) +let addressing_mode_tag_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Direct -> Obj.magic (fun _ dH -> dH) + | Indirect -> Obj.magic (fun _ dH -> dH) + | Ext_indirect -> Obj.magic (fun _ dH -> dH) + | Registr -> Obj.magic (fun _ dH -> dH) + | Acc_a -> Obj.magic (fun _ dH -> dH) + | Acc_b -> Obj.magic (fun _ dH -> dH) + | Dptr -> Obj.magic (fun _ dH -> dH) + | Data -> Obj.magic (fun _ dH -> dH) + | Data16 -> Obj.magic (fun _ dH -> dH) + | Acc_dptr -> Obj.magic (fun _ dH -> dH) + | Acc_pc -> Obj.magic (fun _ dH -> dH) + | Ext_indirect_dptr -> Obj.magic (fun _ dH -> dH) + | Indirect_dptr -> Obj.magic (fun _ dH -> dH) + | Carry -> Obj.magic (fun _ dH -> dH) + | Bit_addr -> Obj.magic (fun _ dH -> dH) + | N_bit_addr -> Obj.magic (fun _ dH -> dH) + | Relative -> Obj.magic (fun _ dH -> dH) + | Addr11 -> Obj.magic (fun _ dH -> dH) + | Addr16 -> Obj.magic (fun _ dH -> dH)) y + +(** val addressing_mode_tag_jmdiscr : + addressing_mode_tag -> addressing_mode_tag -> __ **) +let addressing_mode_tag_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Direct -> Obj.magic (fun _ dH -> dH) + | Indirect -> Obj.magic (fun _ dH -> dH) + | Ext_indirect -> Obj.magic (fun _ dH -> dH) + | Registr -> Obj.magic (fun _ dH -> dH) + | Acc_a -> Obj.magic (fun _ dH -> dH) + | Acc_b -> Obj.magic (fun _ dH -> dH) + | Dptr -> Obj.magic (fun _ dH -> dH) + | Data -> Obj.magic (fun _ dH -> dH) + | Data16 -> Obj.magic (fun _ dH -> dH) + | Acc_dptr -> Obj.magic (fun _ dH -> dH) + | Acc_pc -> Obj.magic (fun _ dH -> dH) + | Ext_indirect_dptr -> Obj.magic (fun _ dH -> dH) + | Indirect_dptr -> Obj.magic (fun _ dH -> dH) + | Carry -> Obj.magic (fun _ dH -> dH) + | Bit_addr -> Obj.magic (fun _ dH -> dH) + | N_bit_addr -> Obj.magic (fun _ dH -> dH) + | Relative -> Obj.magic (fun _ dH -> dH) + | Addr11 -> Obj.magic (fun _ dH -> dH) + | Addr16 -> Obj.magic (fun _ dH -> dH)) y + +(** val eq_a : addressing_mode_tag -> addressing_mode_tag -> Bool.bool **) +let eq_a a b = + match a with + | Direct -> + (match b with + | Direct -> Bool.True + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Indirect -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.True + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Ext_indirect -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.True + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Registr -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.True + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Acc_a -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.True + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Acc_b -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.True + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Dptr -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.True + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Data -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.True + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Data16 -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.True + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Acc_dptr -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.True + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Acc_pc -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.True + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Ext_indirect_dptr -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.True + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Indirect_dptr -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.True + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Carry -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.True + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Bit_addr -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.True + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | N_bit_addr -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.True + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Relative -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.True + | Addr11 -> Bool.False + | Addr16 -> Bool.False) + | Addr11 -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.True + | Addr16 -> Bool.False) + | Addr16 -> + (match b with + | Direct -> Bool.False + | Indirect -> Bool.False + | Ext_indirect -> Bool.False + | Registr -> Bool.False + | Acc_a -> Bool.False + | Acc_b -> Bool.False + | Dptr -> Bool.False + | Data -> Bool.False + | Data16 -> Bool.False + | Acc_dptr -> Bool.False + | Acc_pc -> Bool.False + | Ext_indirect_dptr -> Bool.False + | Indirect_dptr -> Bool.False + | Carry -> Bool.False + | Bit_addr -> Bool.False + | N_bit_addr -> Bool.False + | Relative -> Bool.False + | Addr11 -> Bool.False + | Addr16 -> Bool.True) + +(** val is_a : addressing_mode_tag -> addressing_mode -> Bool.bool **) +let rec is_a d a = + match d with + | Direct -> + (match a with + | DIRECT x -> Bool.True + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Indirect -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.True + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Ext_indirect -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.True + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Registr -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.True + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Acc_a -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.True + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Acc_b -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.True + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Dptr -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.True + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Data -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.True + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Data16 -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.True + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Acc_dptr -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.True + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Acc_pc -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.True + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Ext_indirect_dptr -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.True + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Indirect_dptr -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.True + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Carry -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.True + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Bit_addr -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.True + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | N_bit_addr -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.True + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Relative -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.True + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.False) + | Addr11 -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.True + | ADDR16 x -> Bool.False) + | Addr16 -> + (match a with + | DIRECT x -> Bool.False + | INDIRECT x -> Bool.False + | EXT_INDIRECT x -> Bool.False + | REGISTER x -> Bool.False + | ACC_A -> Bool.False + | ACC_B -> Bool.False + | DPTR -> Bool.False + | DATA x -> Bool.False + | DATA16 x -> Bool.False + | ACC_DPTR -> Bool.False + | ACC_PC -> Bool.False + | EXT_INDIRECT_DPTR -> Bool.False + | INDIRECT_DPTR -> Bool.False + | CARRY -> Bool.False + | BIT_ADDR x -> Bool.False + | N_BIT_ADDR x -> Bool.False + | RELATIVE x -> Bool.False + | ADDR11 x -> Bool.False + | ADDR16 x -> Bool.True) + +(** val is_in : + Nat.nat -> addressing_mode_tag Vector.vector -> addressing_mode -> + Bool.bool **) +let rec is_in n l a = + match l with + | Vector.VEmpty -> Bool.False + | Vector.VCons (m, he, tl) -> Bool.orb (is_a he a) (is_in m tl a) + +type subaddressing_mode = + addressing_mode + (* singleton inductive, whose constructor was mk_subaddressing_mode *) + +(** val subaddressing_mode_rect_Type4 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 **) +let rec subaddressing_mode_rect_Type4 n l h_mk_subaddressing_mode x_19793 = + let subaddressing_modeel = x_19793 in + h_mk_subaddressing_mode subaddressing_modeel __ + +(** val subaddressing_mode_rect_Type5 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 **) +let rec subaddressing_mode_rect_Type5 n l h_mk_subaddressing_mode x_19795 = + let subaddressing_modeel = x_19795 in + h_mk_subaddressing_mode subaddressing_modeel __ + +(** val subaddressing_mode_rect_Type3 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 **) +let rec subaddressing_mode_rect_Type3 n l h_mk_subaddressing_mode x_19797 = + let subaddressing_modeel = x_19797 in + h_mk_subaddressing_mode subaddressing_modeel __ + +(** val subaddressing_mode_rect_Type2 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 **) +let rec subaddressing_mode_rect_Type2 n l h_mk_subaddressing_mode x_19799 = + let subaddressing_modeel = x_19799 in + h_mk_subaddressing_mode subaddressing_modeel __ + +(** val subaddressing_mode_rect_Type1 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 **) +let rec subaddressing_mode_rect_Type1 n l h_mk_subaddressing_mode x_19801 = + let subaddressing_modeel = x_19801 in + h_mk_subaddressing_mode subaddressing_modeel __ + +(** val subaddressing_mode_rect_Type0 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 **) +let rec subaddressing_mode_rect_Type0 n l h_mk_subaddressing_mode x_19803 = + let subaddressing_modeel = x_19803 in + h_mk_subaddressing_mode subaddressing_modeel __ + +(** val subaddressing_modeel : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + addressing_mode **) +let rec subaddressing_modeel n l xxx = + let yyy = xxx in yyy + +(** val subaddressing_mode_inv_rect_Type4 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 **) +let subaddressing_mode_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = subaddressing_mode_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val subaddressing_mode_inv_rect_Type3 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 **) +let subaddressing_mode_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = subaddressing_mode_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val subaddressing_mode_inv_rect_Type2 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 **) +let subaddressing_mode_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = subaddressing_mode_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val subaddressing_mode_inv_rect_Type1 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 **) +let subaddressing_mode_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = subaddressing_mode_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val subaddressing_mode_inv_rect_Type0 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 **) +let subaddressing_mode_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = subaddressing_mode_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val subaddressing_mode_discr : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode -> __ **) +let subaddressing_mode_discr a1 a2 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val subaddressing_mode_jmdiscr : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode -> __ **) +let subaddressing_mode_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val dpi1__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> addressing_mode Types.sig0 **) +let dpi1__o__subaddressing_modeel__o__inject x1 x2 x4 = + subaddressing_modeel x1 x2 x4.Types.dpi1 + +(** val eject__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode + Types.sig0 -> addressing_mode Types.sig0 **) +let eject__o__subaddressing_modeel__o__inject x1 x2 x4 = + subaddressing_modeel x1 x2 (Types.pi1 x4) + +(** val subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + addressing_mode Types.sig0 **) +let subaddressing_modeel__o__inject x1 x2 x3 = + subaddressing_modeel x1 x2 x3 + +(** val dpi1__o__subaddressing_modeel : + Nat.nat -> addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> addressing_mode **) +let dpi1__o__subaddressing_modeel x0 x1 x3 = + subaddressing_modeel x0 x1 x3.Types.dpi1 + +(** val eject__o__subaddressing_modeel : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode + Types.sig0 -> addressing_mode **) +let eject__o__subaddressing_modeel x0 x1 x3 = + subaddressing_modeel x0 x1 (Types.pi1 x3) + +type 'x1 dpi1__o__subaddressing_mode = subaddressing_mode + +type eject__o__subaddressing_mode = subaddressing_mode + +(** val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> subaddressing_mode Types.sig0 **) +let dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__inject x0 x1 x2 x3 x6 = + dpi1__o__subaddressing_modeel x0 x2 x6 + +(** val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> addressing_mode Types.sig0 **) +let dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject x0 x2 x3 x4 x6 = + subaddressing_modeel__o__inject x2 x4 + (dpi1__o__subaddressing_modeel x0 x3 x6) + +(** val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> addressing_mode **) +let dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel x0 x1 x2 x3 x5 = + subaddressing_modeel x1 x3 (dpi1__o__subaddressing_modeel x0 x2 x5) + +(** val eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + subaddressing_mode Types.sig0 **) +let eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__inject x0 x1 x2 x3 x6 = + eject__o__subaddressing_modeel x0 x2 x6 + +(** val eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + addressing_mode Types.sig0 **) +let eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject x0 x2 x3 x4 x6 = + subaddressing_modeel__o__inject x2 x4 + (eject__o__subaddressing_modeel x0 x3 x6) + +(** val eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + addressing_mode **) +let eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel x0 x1 x2 x3 x5 = + subaddressing_modeel x1 x3 (eject__o__subaddressing_modeel x0 x2 x5) + +(** val subaddressing_modeel__o__mk_subaddressing_mode__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode Types.sig0 **) +let subaddressing_modeel__o__mk_subaddressing_mode__o__inject x0 x1 x2 x3 x4 = + subaddressing_modeel x0 x2 x4 + +(** val subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> + addressing_mode Types.sig0 **) +let subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject x0 x2 x3 x4 x5 = + subaddressing_modeel__o__inject x2 x4 (subaddressing_modeel x0 x3 x5) + +(** val subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> + addressing_mode **) +let subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel x0 x1 x2 x3 x4 = + subaddressing_modeel x1 x3 (subaddressing_modeel x0 x2 x4) + +(** val dpi1__o__mk_subaddressing_mode__o__inject : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> subaddressing_mode Types.sig0 **) +let dpi1__o__mk_subaddressing_mode__o__inject x1 x2 x3 = + x2.Types.dpi1 + +(** val dpi1__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> addressing_mode Types.sig0 **) +let dpi1__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject x2 x3 x4 = + subaddressing_modeel__o__inject x2 x4 x3.Types.dpi1 + +(** val dpi1__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> addressing_mode **) +let dpi1__o__mk_subaddressing_mode__o__subaddressing_modeel x1 x2 x3 = + subaddressing_modeel x1 x3 x2.Types.dpi1 + +(** val eject__o__mk_subaddressing_mode__o__inject : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag + Vector.vector -> subaddressing_mode Types.sig0 **) +let eject__o__mk_subaddressing_mode__o__inject x1 x2 x3 = + Types.pi1 x2 + +(** val eject__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag + Vector.vector -> addressing_mode Types.sig0 **) +let eject__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject x2 x3 x4 = + subaddressing_modeel__o__inject x2 x4 (Types.pi1 x3) + +(** val eject__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag + Vector.vector -> addressing_mode **) +let eject__o__mk_subaddressing_mode__o__subaddressing_modeel x1 x2 x3 = + subaddressing_modeel x1 x3 (Types.pi1 x2) + +(** val mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> addressing_mode -> addressing_mode_tag Vector.vector -> + addressing_mode **) +let mk_subaddressing_mode__o__subaddressing_modeel x0 x1 x2 = + subaddressing_modeel x0 x2 x1 + +(** val mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode -> addressing_mode_tag Vector.vector -> + addressing_mode Types.sig0 **) +let mk_subaddressing_mode__o__subaddressing_modeel__o__inject x1 x2 x3 = + subaddressing_modeel__o__inject x1 x3 x2 + +(** val mk_subaddressing_mode__o__inject : + Nat.nat -> addressing_mode -> addressing_mode_tag Vector.vector -> + subaddressing_mode Types.sig0 **) +let mk_subaddressing_mode__o__inject x0 x1 x2 = + x1 + +(** val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> subaddressing_mode **) +let dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode x0 x1 x2 x3 x5 = + dpi1__o__subaddressing_modeel x0 x2 x5 + +(** val eject__o__subaddressing_modeel__o__mk_subaddressing_mode : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + subaddressing_mode **) +let eject__o__subaddressing_modeel__o__mk_subaddressing_mode x0 x1 x2 x3 x5 = + eject__o__subaddressing_modeel x0 x2 x5 + +(** val subaddressing_modeel__o__mk_subaddressing_mode : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode **) +let subaddressing_modeel__o__mk_subaddressing_mode x0 x1 x2 x3 x4 = + subaddressing_modeel x0 x2 x4 + +(** val dpi1__o__mk_subaddressing_mode : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> subaddressing_mode **) +let dpi1__o__mk_subaddressing_mode x1 x2 x3 = + x2.Types.dpi1 + +(** val eject__o__mk_subaddressing_mode : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag + Vector.vector -> subaddressing_mode **) +let eject__o__mk_subaddressing_mode x1 x2 x3 = + Types.pi1 x2 + +type 'a preinstruction = +| ADD of subaddressing_mode * subaddressing_mode +| ADDC of subaddressing_mode * subaddressing_mode +| SUBB of subaddressing_mode * subaddressing_mode +| INC of subaddressing_mode +| DEC of subaddressing_mode +| MUL of subaddressing_mode * subaddressing_mode +| DIV of subaddressing_mode * subaddressing_mode +| DA of subaddressing_mode +| JC of 'a +| JNC of 'a +| JB of subaddressing_mode * 'a +| JNB of subaddressing_mode * 'a +| JBC of subaddressing_mode * 'a +| JZ of 'a +| JNZ of 'a +| CJNE of ((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum * + 'a +| DJNZ of subaddressing_mode * 'a +| ANL of (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| ORL of (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| XRL of ((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| CLR of subaddressing_mode +| CPL of subaddressing_mode +| RL of subaddressing_mode +| RLC of subaddressing_mode +| RR of subaddressing_mode +| RRC of subaddressing_mode +| SWAP of subaddressing_mode +| MOV of ((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| MOVX of ((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| SETB of subaddressing_mode +| PUSH of subaddressing_mode +| POP of subaddressing_mode +| XCH of subaddressing_mode * subaddressing_mode +| XCHD of subaddressing_mode * subaddressing_mode +| RET +| RETI +| NOP +| JMP of subaddressing_mode + +(** val preinstruction_rect_Type4 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode + -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) + -> (subaddressing_mode -> 'a1 -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a1 -> + 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> 'a2 -> + 'a2 -> 'a2 -> (subaddressing_mode -> 'a2) -> 'a1 preinstruction -> 'a2 **) +let rec preinstruction_rect_Type4 h_ADD h_ADDC h_SUBB h_INC h_DEC h_MUL h_DIV h_DA h_JC h_JNC h_JB h_JNB h_JBC h_JZ h_JNZ h_CJNE h_DJNZ h_ANL h_ORL h_XRL h_CLR h_CPL h_RL h_RLC h_RR h_RRC h_SWAP h_MOV h_MOVX h_SETB h_PUSH h_POP h_XCH h_XCHD h_RET h_RETI h_NOP h_JMP = function +| ADD (x_19905, x_19904) -> h_ADD x_19905 x_19904 +| ADDC (x_19907, x_19906) -> h_ADDC x_19907 x_19906 +| SUBB (x_19909, x_19908) -> h_SUBB x_19909 x_19908 +| INC x_19910 -> h_INC x_19910 +| DEC x_19911 -> h_DEC x_19911 +| MUL (x_19913, x_19912) -> h_MUL x_19913 x_19912 +| DIV (x_19915, x_19914) -> h_DIV x_19915 x_19914 +| DA x_19916 -> h_DA x_19916 +| JC x_19917 -> h_JC x_19917 +| JNC x_19918 -> h_JNC x_19918 +| JB (x_19920, x_19919) -> h_JB x_19920 x_19919 +| JNB (x_19922, x_19921) -> h_JNB x_19922 x_19921 +| JBC (x_19924, x_19923) -> h_JBC x_19924 x_19923 +| JZ x_19925 -> h_JZ x_19925 +| JNZ x_19926 -> h_JNZ x_19926 +| CJNE (x_19928, x_19927) -> h_CJNE x_19928 x_19927 +| DJNZ (x_19930, x_19929) -> h_DJNZ x_19930 x_19929 +| ANL x_19931 -> h_ANL x_19931 +| ORL x_19932 -> h_ORL x_19932 +| XRL x_19933 -> h_XRL x_19933 +| CLR x_19934 -> h_CLR x_19934 +| CPL x_19935 -> h_CPL x_19935 +| RL x_19936 -> h_RL x_19936 +| RLC x_19937 -> h_RLC x_19937 +| RR x_19938 -> h_RR x_19938 +| RRC x_19939 -> h_RRC x_19939 +| SWAP x_19940 -> h_SWAP x_19940 +| MOV x_19941 -> h_MOV x_19941 +| MOVX x_19942 -> h_MOVX x_19942 +| SETB x_19943 -> h_SETB x_19943 +| PUSH x_19944 -> h_PUSH x_19944 +| POP x_19945 -> h_POP x_19945 +| XCH (x_19947, x_19946) -> h_XCH x_19947 x_19946 +| XCHD (x_19949, x_19948) -> h_XCHD x_19949 x_19948 +| RET -> h_RET +| RETI -> h_RETI +| NOP -> h_NOP +| JMP x_19950 -> h_JMP x_19950 + +(** val preinstruction_rect_Type5 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode + -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) + -> (subaddressing_mode -> 'a1 -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a1 -> + 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> 'a2 -> + 'a2 -> 'a2 -> (subaddressing_mode -> 'a2) -> 'a1 preinstruction -> 'a2 **) +let rec preinstruction_rect_Type5 h_ADD h_ADDC h_SUBB h_INC h_DEC h_MUL h_DIV h_DA h_JC h_JNC h_JB h_JNB h_JBC h_JZ h_JNZ h_CJNE h_DJNZ h_ANL h_ORL h_XRL h_CLR h_CPL h_RL h_RLC h_RR h_RRC h_SWAP h_MOV h_MOVX h_SETB h_PUSH h_POP h_XCH h_XCHD h_RET h_RETI h_NOP h_JMP = function +| ADD (x_19991, x_19990) -> h_ADD x_19991 x_19990 +| ADDC (x_19993, x_19992) -> h_ADDC x_19993 x_19992 +| SUBB (x_19995, x_19994) -> h_SUBB x_19995 x_19994 +| INC x_19996 -> h_INC x_19996 +| DEC x_19997 -> h_DEC x_19997 +| MUL (x_19999, x_19998) -> h_MUL x_19999 x_19998 +| DIV (x_20001, x_20000) -> h_DIV x_20001 x_20000 +| DA x_20002 -> h_DA x_20002 +| JC x_20003 -> h_JC x_20003 +| JNC x_20004 -> h_JNC x_20004 +| JB (x_20006, x_20005) -> h_JB x_20006 x_20005 +| JNB (x_20008, x_20007) -> h_JNB x_20008 x_20007 +| JBC (x_20010, x_20009) -> h_JBC x_20010 x_20009 +| JZ x_20011 -> h_JZ x_20011 +| JNZ x_20012 -> h_JNZ x_20012 +| CJNE (x_20014, x_20013) -> h_CJNE x_20014 x_20013 +| DJNZ (x_20016, x_20015) -> h_DJNZ x_20016 x_20015 +| ANL x_20017 -> h_ANL x_20017 +| ORL x_20018 -> h_ORL x_20018 +| XRL x_20019 -> h_XRL x_20019 +| CLR x_20020 -> h_CLR x_20020 +| CPL x_20021 -> h_CPL x_20021 +| RL x_20022 -> h_RL x_20022 +| RLC x_20023 -> h_RLC x_20023 +| RR x_20024 -> h_RR x_20024 +| RRC x_20025 -> h_RRC x_20025 +| SWAP x_20026 -> h_SWAP x_20026 +| MOV x_20027 -> h_MOV x_20027 +| MOVX x_20028 -> h_MOVX x_20028 +| SETB x_20029 -> h_SETB x_20029 +| PUSH x_20030 -> h_PUSH x_20030 +| POP x_20031 -> h_POP x_20031 +| XCH (x_20033, x_20032) -> h_XCH x_20033 x_20032 +| XCHD (x_20035, x_20034) -> h_XCHD x_20035 x_20034 +| RET -> h_RET +| RETI -> h_RETI +| NOP -> h_NOP +| JMP x_20036 -> h_JMP x_20036 + +(** val preinstruction_rect_Type3 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode + -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) + -> (subaddressing_mode -> 'a1 -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a1 -> + 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> 'a2 -> + 'a2 -> 'a2 -> (subaddressing_mode -> 'a2) -> 'a1 preinstruction -> 'a2 **) +let rec preinstruction_rect_Type3 h_ADD h_ADDC h_SUBB h_INC h_DEC h_MUL h_DIV h_DA h_JC h_JNC h_JB h_JNB h_JBC h_JZ h_JNZ h_CJNE h_DJNZ h_ANL h_ORL h_XRL h_CLR h_CPL h_RL h_RLC h_RR h_RRC h_SWAP h_MOV h_MOVX h_SETB h_PUSH h_POP h_XCH h_XCHD h_RET h_RETI h_NOP h_JMP = function +| ADD (x_20077, x_20076) -> h_ADD x_20077 x_20076 +| ADDC (x_20079, x_20078) -> h_ADDC x_20079 x_20078 +| SUBB (x_20081, x_20080) -> h_SUBB x_20081 x_20080 +| INC x_20082 -> h_INC x_20082 +| DEC x_20083 -> h_DEC x_20083 +| MUL (x_20085, x_20084) -> h_MUL x_20085 x_20084 +| DIV (x_20087, x_20086) -> h_DIV x_20087 x_20086 +| DA x_20088 -> h_DA x_20088 +| JC x_20089 -> h_JC x_20089 +| JNC x_20090 -> h_JNC x_20090 +| JB (x_20092, x_20091) -> h_JB x_20092 x_20091 +| JNB (x_20094, x_20093) -> h_JNB x_20094 x_20093 +| JBC (x_20096, x_20095) -> h_JBC x_20096 x_20095 +| JZ x_20097 -> h_JZ x_20097 +| JNZ x_20098 -> h_JNZ x_20098 +| CJNE (x_20100, x_20099) -> h_CJNE x_20100 x_20099 +| DJNZ (x_20102, x_20101) -> h_DJNZ x_20102 x_20101 +| ANL x_20103 -> h_ANL x_20103 +| ORL x_20104 -> h_ORL x_20104 +| XRL x_20105 -> h_XRL x_20105 +| CLR x_20106 -> h_CLR x_20106 +| CPL x_20107 -> h_CPL x_20107 +| RL x_20108 -> h_RL x_20108 +| RLC x_20109 -> h_RLC x_20109 +| RR x_20110 -> h_RR x_20110 +| RRC x_20111 -> h_RRC x_20111 +| SWAP x_20112 -> h_SWAP x_20112 +| MOV x_20113 -> h_MOV x_20113 +| MOVX x_20114 -> h_MOVX x_20114 +| SETB x_20115 -> h_SETB x_20115 +| PUSH x_20116 -> h_PUSH x_20116 +| POP x_20117 -> h_POP x_20117 +| XCH (x_20119, x_20118) -> h_XCH x_20119 x_20118 +| XCHD (x_20121, x_20120) -> h_XCHD x_20121 x_20120 +| RET -> h_RET +| RETI -> h_RETI +| NOP -> h_NOP +| JMP x_20122 -> h_JMP x_20122 + +(** val preinstruction_rect_Type2 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode + -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) + -> (subaddressing_mode -> 'a1 -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a1 -> + 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> 'a2 -> + 'a2 -> 'a2 -> (subaddressing_mode -> 'a2) -> 'a1 preinstruction -> 'a2 **) +let rec preinstruction_rect_Type2 h_ADD h_ADDC h_SUBB h_INC h_DEC h_MUL h_DIV h_DA h_JC h_JNC h_JB h_JNB h_JBC h_JZ h_JNZ h_CJNE h_DJNZ h_ANL h_ORL h_XRL h_CLR h_CPL h_RL h_RLC h_RR h_RRC h_SWAP h_MOV h_MOVX h_SETB h_PUSH h_POP h_XCH h_XCHD h_RET h_RETI h_NOP h_JMP = function +| ADD (x_20163, x_20162) -> h_ADD x_20163 x_20162 +| ADDC (x_20165, x_20164) -> h_ADDC x_20165 x_20164 +| SUBB (x_20167, x_20166) -> h_SUBB x_20167 x_20166 +| INC x_20168 -> h_INC x_20168 +| DEC x_20169 -> h_DEC x_20169 +| MUL (x_20171, x_20170) -> h_MUL x_20171 x_20170 +| DIV (x_20173, x_20172) -> h_DIV x_20173 x_20172 +| DA x_20174 -> h_DA x_20174 +| JC x_20175 -> h_JC x_20175 +| JNC x_20176 -> h_JNC x_20176 +| JB (x_20178, x_20177) -> h_JB x_20178 x_20177 +| JNB (x_20180, x_20179) -> h_JNB x_20180 x_20179 +| JBC (x_20182, x_20181) -> h_JBC x_20182 x_20181 +| JZ x_20183 -> h_JZ x_20183 +| JNZ x_20184 -> h_JNZ x_20184 +| CJNE (x_20186, x_20185) -> h_CJNE x_20186 x_20185 +| DJNZ (x_20188, x_20187) -> h_DJNZ x_20188 x_20187 +| ANL x_20189 -> h_ANL x_20189 +| ORL x_20190 -> h_ORL x_20190 +| XRL x_20191 -> h_XRL x_20191 +| CLR x_20192 -> h_CLR x_20192 +| CPL x_20193 -> h_CPL x_20193 +| RL x_20194 -> h_RL x_20194 +| RLC x_20195 -> h_RLC x_20195 +| RR x_20196 -> h_RR x_20196 +| RRC x_20197 -> h_RRC x_20197 +| SWAP x_20198 -> h_SWAP x_20198 +| MOV x_20199 -> h_MOV x_20199 +| MOVX x_20200 -> h_MOVX x_20200 +| SETB x_20201 -> h_SETB x_20201 +| PUSH x_20202 -> h_PUSH x_20202 +| POP x_20203 -> h_POP x_20203 +| XCH (x_20205, x_20204) -> h_XCH x_20205 x_20204 +| XCHD (x_20207, x_20206) -> h_XCHD x_20207 x_20206 +| RET -> h_RET +| RETI -> h_RETI +| NOP -> h_NOP +| JMP x_20208 -> h_JMP x_20208 + +(** val preinstruction_rect_Type1 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode + -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) + -> (subaddressing_mode -> 'a1 -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a1 -> + 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> 'a2 -> + 'a2 -> 'a2 -> (subaddressing_mode -> 'a2) -> 'a1 preinstruction -> 'a2 **) +let rec preinstruction_rect_Type1 h_ADD h_ADDC h_SUBB h_INC h_DEC h_MUL h_DIV h_DA h_JC h_JNC h_JB h_JNB h_JBC h_JZ h_JNZ h_CJNE h_DJNZ h_ANL h_ORL h_XRL h_CLR h_CPL h_RL h_RLC h_RR h_RRC h_SWAP h_MOV h_MOVX h_SETB h_PUSH h_POP h_XCH h_XCHD h_RET h_RETI h_NOP h_JMP = function +| ADD (x_20249, x_20248) -> h_ADD x_20249 x_20248 +| ADDC (x_20251, x_20250) -> h_ADDC x_20251 x_20250 +| SUBB (x_20253, x_20252) -> h_SUBB x_20253 x_20252 +| INC x_20254 -> h_INC x_20254 +| DEC x_20255 -> h_DEC x_20255 +| MUL (x_20257, x_20256) -> h_MUL x_20257 x_20256 +| DIV (x_20259, x_20258) -> h_DIV x_20259 x_20258 +| DA x_20260 -> h_DA x_20260 +| JC x_20261 -> h_JC x_20261 +| JNC x_20262 -> h_JNC x_20262 +| JB (x_20264, x_20263) -> h_JB x_20264 x_20263 +| JNB (x_20266, x_20265) -> h_JNB x_20266 x_20265 +| JBC (x_20268, x_20267) -> h_JBC x_20268 x_20267 +| JZ x_20269 -> h_JZ x_20269 +| JNZ x_20270 -> h_JNZ x_20270 +| CJNE (x_20272, x_20271) -> h_CJNE x_20272 x_20271 +| DJNZ (x_20274, x_20273) -> h_DJNZ x_20274 x_20273 +| ANL x_20275 -> h_ANL x_20275 +| ORL x_20276 -> h_ORL x_20276 +| XRL x_20277 -> h_XRL x_20277 +| CLR x_20278 -> h_CLR x_20278 +| CPL x_20279 -> h_CPL x_20279 +| RL x_20280 -> h_RL x_20280 +| RLC x_20281 -> h_RLC x_20281 +| RR x_20282 -> h_RR x_20282 +| RRC x_20283 -> h_RRC x_20283 +| SWAP x_20284 -> h_SWAP x_20284 +| MOV x_20285 -> h_MOV x_20285 +| MOVX x_20286 -> h_MOVX x_20286 +| SETB x_20287 -> h_SETB x_20287 +| PUSH x_20288 -> h_PUSH x_20288 +| POP x_20289 -> h_POP x_20289 +| XCH (x_20291, x_20290) -> h_XCH x_20291 x_20290 +| XCHD (x_20293, x_20292) -> h_XCHD x_20293 x_20292 +| RET -> h_RET +| RETI -> h_RETI +| NOP -> h_NOP +| JMP x_20294 -> h_JMP x_20294 + +(** val preinstruction_rect_Type0 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode + -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) + -> (subaddressing_mode -> 'a1 -> 'a2) -> ('a1 -> 'a2) -> ('a1 -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a1 -> + 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> ((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode + -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> 'a2) -> 'a2 -> + 'a2 -> 'a2 -> (subaddressing_mode -> 'a2) -> 'a1 preinstruction -> 'a2 **) +let rec preinstruction_rect_Type0 h_ADD h_ADDC h_SUBB h_INC h_DEC h_MUL h_DIV h_DA h_JC h_JNC h_JB h_JNB h_JBC h_JZ h_JNZ h_CJNE h_DJNZ h_ANL h_ORL h_XRL h_CLR h_CPL h_RL h_RLC h_RR h_RRC h_SWAP h_MOV h_MOVX h_SETB h_PUSH h_POP h_XCH h_XCHD h_RET h_RETI h_NOP h_JMP = function +| ADD (x_20335, x_20334) -> h_ADD x_20335 x_20334 +| ADDC (x_20337, x_20336) -> h_ADDC x_20337 x_20336 +| SUBB (x_20339, x_20338) -> h_SUBB x_20339 x_20338 +| INC x_20340 -> h_INC x_20340 +| DEC x_20341 -> h_DEC x_20341 +| MUL (x_20343, x_20342) -> h_MUL x_20343 x_20342 +| DIV (x_20345, x_20344) -> h_DIV x_20345 x_20344 +| DA x_20346 -> h_DA x_20346 +| JC x_20347 -> h_JC x_20347 +| JNC x_20348 -> h_JNC x_20348 +| JB (x_20350, x_20349) -> h_JB x_20350 x_20349 +| JNB (x_20352, x_20351) -> h_JNB x_20352 x_20351 +| JBC (x_20354, x_20353) -> h_JBC x_20354 x_20353 +| JZ x_20355 -> h_JZ x_20355 +| JNZ x_20356 -> h_JNZ x_20356 +| CJNE (x_20358, x_20357) -> h_CJNE x_20358 x_20357 +| DJNZ (x_20360, x_20359) -> h_DJNZ x_20360 x_20359 +| ANL x_20361 -> h_ANL x_20361 +| ORL x_20362 -> h_ORL x_20362 +| XRL x_20363 -> h_XRL x_20363 +| CLR x_20364 -> h_CLR x_20364 +| CPL x_20365 -> h_CPL x_20365 +| RL x_20366 -> h_RL x_20366 +| RLC x_20367 -> h_RLC x_20367 +| RR x_20368 -> h_RR x_20368 +| RRC x_20369 -> h_RRC x_20369 +| SWAP x_20370 -> h_SWAP x_20370 +| MOV x_20371 -> h_MOV x_20371 +| MOVX x_20372 -> h_MOVX x_20372 +| SETB x_20373 -> h_SETB x_20373 +| PUSH x_20374 -> h_PUSH x_20374 +| POP x_20375 -> h_POP x_20375 +| XCH (x_20377, x_20376) -> h_XCH x_20377 x_20376 +| XCHD (x_20379, x_20378) -> h_XCHD x_20379 x_20378 +| RET -> h_RET +| RETI -> h_RETI +| NOP -> h_NOP +| JMP x_20380 -> h_JMP x_20380 + +(** val preinstruction_inv_rect_Type4 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 + -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 + -> __ -> 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> + (__ -> 'a2) -> (__ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 **) +let preinstruction_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 h38 = + let hcut = + preinstruction_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 + h33 h34 h35 h36 h37 h38 hterm + in + hcut __ + +(** val preinstruction_inv_rect_Type3 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 + -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 + -> __ -> 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> + (__ -> 'a2) -> (__ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 **) +let preinstruction_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 h38 = + let hcut = + preinstruction_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 + h33 h34 h35 h36 h37 h38 hterm + in + hcut __ + +(** val preinstruction_inv_rect_Type2 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 + -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 + -> __ -> 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> + (__ -> 'a2) -> (__ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 **) +let preinstruction_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 h38 = + let hcut = + preinstruction_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 + h33 h34 h35 h36 h37 h38 hterm + in + hcut __ + +(** val preinstruction_inv_rect_Type1 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 + -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 + -> __ -> 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> + (__ -> 'a2) -> (__ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 **) +let preinstruction_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 h38 = + let hcut = + preinstruction_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 + h33 h34 h35 h36 h37 h38 hterm + in + hcut __ + +(** val preinstruction_inv_rect_Type0 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 + -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 + -> __ -> 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) + -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> + (__ -> 'a2) -> (__ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 **) +let preinstruction_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 h38 = + let hcut = + preinstruction_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 + h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 + h33 h34 h35 h36 h37 h38 hterm + in + hcut __ + +(** val preinstruction_discr : + 'a1 preinstruction -> 'a1 preinstruction -> __ **) +let preinstruction_discr x y = + Logic.eq_rect_Type2 x + (match x with + | ADD (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | ADDC (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | SUBB (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | INC a0 -> Obj.magic (fun _ dH -> dH __) + | DEC a0 -> Obj.magic (fun _ dH -> dH __) + | MUL (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | DIV (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | DA a0 -> Obj.magic (fun _ dH -> dH __) + | JC a0 -> Obj.magic (fun _ dH -> dH __) + | JNC a0 -> Obj.magic (fun _ dH -> dH __) + | JB (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | JNB (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | JBC (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | JZ a0 -> Obj.magic (fun _ dH -> dH __) + | JNZ a0 -> Obj.magic (fun _ dH -> dH __) + | CJNE (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | DJNZ (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | ANL a0 -> Obj.magic (fun _ dH -> dH __) + | ORL a0 -> Obj.magic (fun _ dH -> dH __) + | XRL a0 -> Obj.magic (fun _ dH -> dH __) + | CLR a0 -> Obj.magic (fun _ dH -> dH __) + | CPL a0 -> Obj.magic (fun _ dH -> dH __) + | RL a0 -> Obj.magic (fun _ dH -> dH __) + | RLC a0 -> Obj.magic (fun _ dH -> dH __) + | RR a0 -> Obj.magic (fun _ dH -> dH __) + | RRC a0 -> Obj.magic (fun _ dH -> dH __) + | SWAP a0 -> Obj.magic (fun _ dH -> dH __) + | MOV a0 -> Obj.magic (fun _ dH -> dH __) + | MOVX a0 -> Obj.magic (fun _ dH -> dH __) + | SETB a0 -> Obj.magic (fun _ dH -> dH __) + | PUSH a0 -> Obj.magic (fun _ dH -> dH __) + | POP a0 -> Obj.magic (fun _ dH -> dH __) + | XCH (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | XCHD (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | RET -> Obj.magic (fun _ dH -> dH) + | RETI -> Obj.magic (fun _ dH -> dH) + | NOP -> Obj.magic (fun _ dH -> dH) + | JMP a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val preinstruction_jmdiscr : + 'a1 preinstruction -> 'a1 preinstruction -> __ **) +let preinstruction_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | ADD (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | ADDC (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | SUBB (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | INC a0 -> Obj.magic (fun _ dH -> dH __) + | DEC a0 -> Obj.magic (fun _ dH -> dH __) + | MUL (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | DIV (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | DA a0 -> Obj.magic (fun _ dH -> dH __) + | JC a0 -> Obj.magic (fun _ dH -> dH __) + | JNC a0 -> Obj.magic (fun _ dH -> dH __) + | JB (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | JNB (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | JBC (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | JZ a0 -> Obj.magic (fun _ dH -> dH __) + | JNZ a0 -> Obj.magic (fun _ dH -> dH __) + | CJNE (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | DJNZ (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | ANL a0 -> Obj.magic (fun _ dH -> dH __) + | ORL a0 -> Obj.magic (fun _ dH -> dH __) + | XRL a0 -> Obj.magic (fun _ dH -> dH __) + | CLR a0 -> Obj.magic (fun _ dH -> dH __) + | CPL a0 -> Obj.magic (fun _ dH -> dH __) + | RL a0 -> Obj.magic (fun _ dH -> dH __) + | RLC a0 -> Obj.magic (fun _ dH -> dH __) + | RR a0 -> Obj.magic (fun _ dH -> dH __) + | RRC a0 -> Obj.magic (fun _ dH -> dH __) + | SWAP a0 -> Obj.magic (fun _ dH -> dH __) + | MOV a0 -> Obj.magic (fun _ dH -> dH __) + | MOVX a0 -> Obj.magic (fun _ dH -> dH __) + | SETB a0 -> Obj.magic (fun _ dH -> dH __) + | PUSH a0 -> Obj.magic (fun _ dH -> dH __) + | POP a0 -> Obj.magic (fun _ dH -> dH __) + | XCH (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | XCHD (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | RET -> Obj.magic (fun _ dH -> dH) + | RETI -> Obj.magic (fun _ dH -> dH) + | NOP -> Obj.magic (fun _ dH -> dH) + | JMP a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val eq_preinstruction : + subaddressing_mode preinstruction -> subaddressing_mode preinstruction -> + Bool.bool **) +let eq_preinstruction i j = + match i with + | ADD (arg1, arg2) -> + (match j with + | ADD (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Direct, (Vector.VCons ((Nat.S Nat.O), Indirect, + (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))))) arg2) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Direct, (Vector.VCons ((Nat.S Nat.O), Indirect, + (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))))) arg2')) + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | ADDC (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Direct, (Vector.VCons ((Nat.S Nat.O), Indirect, + (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))))) arg2) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Direct, (Vector.VCons ((Nat.S Nat.O), Indirect, + (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))))) arg2')) + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | SUBB (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Direct, (Vector.VCons ((Nat.S Nat.O), Indirect, + (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))))) arg2) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Direct, (Vector.VCons ((Nat.S Nat.O), Indirect, + (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))))) arg2')) + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | INC arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC arg' -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Dptr, + Vector.VEmpty)))))))))) arg) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Dptr, + Vector.VEmpty)))))))))) arg') + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | DEC arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC arg' -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Acc_a, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Registr, (Vector.VCons ((Nat.S Nat.O), Direct, + (Vector.VCons (Nat.O, Indirect, Vector.VEmpty)))))))) arg) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Acc_a, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Registr, (Vector.VCons ((Nat.S Nat.O), Direct, + (Vector.VCons (Nat.O, Indirect, Vector.VEmpty)))))))) arg') + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | MUL (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_b, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_b, + Vector.VEmpty)) arg2')) + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | DIV (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_b, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_b, + Vector.VEmpty)) arg2')) + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | DA arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg') + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | JC arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg') + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | JNC arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg') + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | JB (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2')) + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | JNB (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2')) + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | JBC (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2')) + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | JZ arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg') + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | JNZ arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg') + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | CJNE (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (arg1', arg2') -> + let prod_eq_left = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Direct, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Direct, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h1)) + in + let prod_eq_right = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Registr, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))) h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Registr, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Data, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Data, + Vector.VEmpty)) h1)) + in + let arg1_eq = Util.eq_sum prod_eq_left prod_eq_right in + Bool.andb (arg1_eq arg1 arg1') + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2')) + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | DJNZ (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + Registr, (Vector.VCons (Nat.O, Direct, Vector.VEmpty)))) arg1) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + Registr, (Vector.VCons (Nat.O, Direct, Vector.VEmpty)))) arg1')) + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg2')) + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | ANL arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL arg' -> + let prod_eq_left1 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Data, + Vector.VEmpty)))))))) h) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Data, + Vector.VEmpty)))))))) h1)) + in + let prod_eq_left2 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Acc_a, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Acc_a, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h1)) + in + let prod_eq_left = Util.eq_sum prod_eq_left1 prod_eq_left2 in + let prod_eq_right = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Bit_addr, (Vector.VCons (Nat.O, N_bit_addr, + Vector.VEmpty)))) h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Bit_addr, (Vector.VCons (Nat.O, N_bit_addr, + Vector.VEmpty)))) h1)) + in + let sum_eq = Util.eq_sum prod_eq_left prod_eq_right in sum_eq arg arg' + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | ORL arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL arg' -> + let prod_eq_left1 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Data, (Vector.VCons + ((Nat.S Nat.O), Direct, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))))))) h) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Data, (Vector.VCons + ((Nat.S Nat.O), Direct, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))))))) h1)) + in + let prod_eq_left2 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Acc_a, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Acc_a, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h1)) + in + let prod_eq_left = Util.eq_sum prod_eq_left1 prod_eq_left2 in + let prod_eq_right = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Bit_addr, (Vector.VCons (Nat.O, N_bit_addr, + Vector.VEmpty)))) h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Bit_addr, (Vector.VCons (Nat.O, N_bit_addr, + Vector.VEmpty)))) h1)) + in + let sum_eq = Util.eq_sum prod_eq_left prod_eq_right in sum_eq arg arg' + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | XRL arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL arg' -> + let prod_eq_left = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Data, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Registr, (Vector.VCons + ((Nat.S Nat.O), Direct, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))))))) h) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Data, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Registr, (Vector.VCons + ((Nat.S Nat.O), Direct, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))))))) h1)) + in + let prod_eq_right = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Acc_a, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Acc_a, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))) + h1)) + in + let sum_eq = Util.eq_sum prod_eq_left prod_eq_right in sum_eq arg arg' + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | CLR arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR arg' -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Acc_a, (Vector.VCons ((Nat.S Nat.O), Carry, + (Vector.VCons (Nat.O, Bit_addr, Vector.VEmpty)))))) arg) + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Acc_a, (Vector.VCons ((Nat.S Nat.O), Carry, + (Vector.VCons (Nat.O, Bit_addr, Vector.VEmpty)))))) arg') + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | CPL arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL arg' -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Acc_a, (Vector.VCons ((Nat.S Nat.O), Carry, + (Vector.VCons (Nat.O, Bit_addr, Vector.VEmpty)))))) arg) + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Acc_a, (Vector.VCons ((Nat.S Nat.O), Carry, + (Vector.VCons (Nat.O, Bit_addr, Vector.VEmpty)))))) arg') + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | RL arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg') + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | RLC arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg') + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | RR arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg') + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | RRC arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg') + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | SWAP arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg') + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | MOV arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV arg' -> + let prod_eq_6 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Data, + Vector.VEmpty)))))))) h) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Data, + Vector.VEmpty)))))))) h1)) + in + let prod_eq_5 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Registr, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))) h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Registr, (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)))) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Acc_a, (Vector.VCons ((Nat.S Nat.O), + Direct, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))) h) + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Acc_a, (Vector.VCons ((Nat.S Nat.O), + Direct, (Vector.VCons (Nat.O, Data, Vector.VEmpty)))))) h1)) + in + let prod_eq_4 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Data, + Vector.VEmpty)))))))))) h) + (subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Direct, (Vector.VCons + ((Nat.S Nat.O), Indirect, (Vector.VCons (Nat.O, Data, + Vector.VEmpty)))))))))) h1)) + in + let prod_eq_3 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Dptr, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Dptr, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Data16, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Data16, + Vector.VEmpty)) h1)) + in + let prod_eq_2 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) h1)) + in + let prod_eq_1 = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Bit_addr, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Carry, + Vector.VEmpty)) h1)) + in + let sum_eq_1 = Util.eq_sum prod_eq_6 prod_eq_5 in + let sum_eq_2 = Util.eq_sum sum_eq_1 prod_eq_4 in + let sum_eq_3 = Util.eq_sum sum_eq_2 prod_eq_3 in + let sum_eq_4 = Util.eq_sum sum_eq_3 prod_eq_2 in + let sum_eq_5 = Util.eq_sum sum_eq_4 prod_eq_1 in sum_eq_5 arg arg' + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | MOVX arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX arg' -> + let prod_eq_left = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Ext_indirect, (Vector.VCons (Nat.O, Ext_indirect_dptr, + Vector.VEmpty)))) h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Ext_indirect, (Vector.VCons (Nat.O, Ext_indirect_dptr, + Vector.VEmpty)))) h1)) + in + let prod_eq_right = + Util.eq_prod (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Ext_indirect, (Vector.VCons (Nat.O, Ext_indirect_dptr, + Vector.VEmpty)))) h) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), Ext_indirect, (Vector.VCons (Nat.O, Ext_indirect_dptr, + Vector.VEmpty)))) h1)) (fun h h1 -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) h1)) + in + let sum_eq = Util.eq_sum prod_eq_left prod_eq_right in sum_eq arg arg' + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | SETB arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB arg' -> + eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + Carry, (Vector.VCons (Nat.O, Bit_addr, Vector.VEmpty)))) arg) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + Carry, (Vector.VCons (Nat.O, Bit_addr, Vector.VEmpty)))) arg') + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | PUSH arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) arg') + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | POP arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Direct, + Vector.VEmpty)) arg') + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | XCH (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Registr, (Vector.VCons ((Nat.S Nat.O), Direct, + (Vector.VCons (Nat.O, Indirect, Vector.VEmpty)))))) arg2) + (subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Registr, (Vector.VCons ((Nat.S Nat.O), Direct, + (Vector.VCons (Nat.O, Indirect, Vector.VEmpty)))))) arg2')) + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | XCHD (arg1, arg2) -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)) arg2) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Indirect, + Vector.VEmpty)) arg2')) + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | RET -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.True + | RETI -> Bool.False + | NOP -> Bool.False + | JMP x -> Bool.False) + | RETI -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.True + | NOP -> Bool.False + | JMP x -> Bool.False) + | NOP -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.True + | JMP x -> Bool.False) + | JMP arg -> + (match j with + | ADD (x, x0) -> Bool.False + | ADDC (x, x0) -> Bool.False + | SUBB (x, x0) -> Bool.False + | INC x -> Bool.False + | DEC x -> Bool.False + | MUL (x, x0) -> Bool.False + | DIV (x, x0) -> Bool.False + | DA x -> Bool.False + | JC x -> Bool.False + | JNC x -> Bool.False + | JB (x, x0) -> Bool.False + | JNB (x, x0) -> Bool.False + | JBC (x, x0) -> Bool.False + | JZ x -> Bool.False + | JNZ x -> Bool.False + | CJNE (x, x0) -> Bool.False + | DJNZ (x, x0) -> Bool.False + | ANL x -> Bool.False + | ORL x -> Bool.False + | XRL x -> Bool.False + | CLR x -> Bool.False + | CPL x -> Bool.False + | RL x -> Bool.False + | RLC x -> Bool.False + | RR x -> Bool.False + | RRC x -> Bool.False + | SWAP x -> Bool.False + | MOV x -> Bool.False + | MOVX x -> Bool.False + | SETB x -> Bool.False + | PUSH x -> Bool.False + | POP x -> Bool.False + | XCH (x, x0) -> Bool.False + | XCHD (x, x0) -> Bool.False + | RET -> Bool.False + | RETI -> Bool.False + | NOP -> Bool.False + | JMP arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_dptr, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_dptr, + Vector.VEmpty)) arg')) + +type instruction = +| ACALL of subaddressing_mode +| LCALL of subaddressing_mode +| AJMP of subaddressing_mode +| LJMP of subaddressing_mode +| SJMP of subaddressing_mode +| MOVC of subaddressing_mode * subaddressing_mode +| RealInstruction of subaddressing_mode preinstruction + +(** val instruction_rect_Type4 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode + -> 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> + 'a1 **) +let rec instruction_rect_Type4 h_ACALL h_LCALL h_AJMP h_LJMP h_SJMP h_MOVC h_RealInstruction = function +| ACALL x_20952 -> h_ACALL x_20952 +| LCALL x_20953 -> h_LCALL x_20953 +| AJMP x_20954 -> h_AJMP x_20954 +| LJMP x_20955 -> h_LJMP x_20955 +| SJMP x_20956 -> h_SJMP x_20956 +| MOVC (x_20958, x_20957) -> h_MOVC x_20958 x_20957 +| RealInstruction x_20959 -> h_RealInstruction x_20959 + +(** val instruction_rect_Type5 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode + -> 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> + 'a1 **) +let rec instruction_rect_Type5 h_ACALL h_LCALL h_AJMP h_LJMP h_SJMP h_MOVC h_RealInstruction = function +| ACALL x_20968 -> h_ACALL x_20968 +| LCALL x_20969 -> h_LCALL x_20969 +| AJMP x_20970 -> h_AJMP x_20970 +| LJMP x_20971 -> h_LJMP x_20971 +| SJMP x_20972 -> h_SJMP x_20972 +| MOVC (x_20974, x_20973) -> h_MOVC x_20974 x_20973 +| RealInstruction x_20975 -> h_RealInstruction x_20975 + +(** val instruction_rect_Type3 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode + -> 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> + 'a1 **) +let rec instruction_rect_Type3 h_ACALL h_LCALL h_AJMP h_LJMP h_SJMP h_MOVC h_RealInstruction = function +| ACALL x_20984 -> h_ACALL x_20984 +| LCALL x_20985 -> h_LCALL x_20985 +| AJMP x_20986 -> h_AJMP x_20986 +| LJMP x_20987 -> h_LJMP x_20987 +| SJMP x_20988 -> h_SJMP x_20988 +| MOVC (x_20990, x_20989) -> h_MOVC x_20990 x_20989 +| RealInstruction x_20991 -> h_RealInstruction x_20991 + +(** val instruction_rect_Type2 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode + -> 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> + 'a1 **) +let rec instruction_rect_Type2 h_ACALL h_LCALL h_AJMP h_LJMP h_SJMP h_MOVC h_RealInstruction = function +| ACALL x_21000 -> h_ACALL x_21000 +| LCALL x_21001 -> h_LCALL x_21001 +| AJMP x_21002 -> h_AJMP x_21002 +| LJMP x_21003 -> h_LJMP x_21003 +| SJMP x_21004 -> h_SJMP x_21004 +| MOVC (x_21006, x_21005) -> h_MOVC x_21006 x_21005 +| RealInstruction x_21007 -> h_RealInstruction x_21007 + +(** val instruction_rect_Type1 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode + -> 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> + 'a1 **) +let rec instruction_rect_Type1 h_ACALL h_LCALL h_AJMP h_LJMP h_SJMP h_MOVC h_RealInstruction = function +| ACALL x_21016 -> h_ACALL x_21016 +| LCALL x_21017 -> h_LCALL x_21017 +| AJMP x_21018 -> h_AJMP x_21018 +| LJMP x_21019 -> h_LJMP x_21019 +| SJMP x_21020 -> h_SJMP x_21020 +| MOVC (x_21022, x_21021) -> h_MOVC x_21022 x_21021 +| RealInstruction x_21023 -> h_RealInstruction x_21023 + +(** val instruction_rect_Type0 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode + -> 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> + 'a1 **) +let rec instruction_rect_Type0 h_ACALL h_LCALL h_AJMP h_LJMP h_SJMP h_MOVC h_RealInstruction = function +| ACALL x_21032 -> h_ACALL x_21032 +| LCALL x_21033 -> h_LCALL x_21033 +| AJMP x_21034 -> h_AJMP x_21034 +| LJMP x_21035 -> h_LJMP x_21035 +| SJMP x_21036 -> h_SJMP x_21036 +| MOVC (x_21038, x_21037) -> h_MOVC x_21038 x_21037 +| RealInstruction x_21039 -> h_RealInstruction x_21039 + +(** val instruction_inv_rect_Type4 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction + -> __ -> 'a1) -> 'a1 **) +let instruction_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = instruction_rect_Type4 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val instruction_inv_rect_Type3 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction + -> __ -> 'a1) -> 'a1 **) +let instruction_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = instruction_rect_Type3 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val instruction_inv_rect_Type2 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction + -> __ -> 'a1) -> 'a1 **) +let instruction_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = instruction_rect_Type2 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val instruction_inv_rect_Type1 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction + -> __ -> 'a1) -> 'a1 **) +let instruction_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = instruction_rect_Type1 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val instruction_inv_rect_Type0 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode + -> subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction + -> __ -> 'a1) -> 'a1 **) +let instruction_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = instruction_rect_Type0 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val instruction_discr : instruction -> instruction -> __ **) +let instruction_discr x y = + Logic.eq_rect_Type2 x + (match x with + | ACALL a0 -> Obj.magic (fun _ dH -> dH __) + | LCALL a0 -> Obj.magic (fun _ dH -> dH __) + | AJMP a0 -> Obj.magic (fun _ dH -> dH __) + | LJMP a0 -> Obj.magic (fun _ dH -> dH __) + | SJMP a0 -> Obj.magic (fun _ dH -> dH __) + | MOVC (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | RealInstruction a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val instruction_jmdiscr : instruction -> instruction -> __ **) +let instruction_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | ACALL a0 -> Obj.magic (fun _ dH -> dH __) + | LCALL a0 -> Obj.magic (fun _ dH -> dH __) + | AJMP a0 -> Obj.magic (fun _ dH -> dH __) + | LJMP a0 -> Obj.magic (fun _ dH -> dH __) + | SJMP a0 -> Obj.magic (fun _ dH -> dH __) + | MOVC (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | RealInstruction a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val dpi1__o__RealInstruction__o__inject : + (subaddressing_mode preinstruction, 'a1) Types.dPair -> instruction + Types.sig0 **) +let dpi1__o__RealInstruction__o__inject x2 = + RealInstruction x2.Types.dpi1 + +(** val eject__o__RealInstruction__o__inject : + subaddressing_mode preinstruction Types.sig0 -> instruction Types.sig0 **) +let eject__o__RealInstruction__o__inject x2 = + RealInstruction (Types.pi1 x2) + +(** val realInstruction__o__inject : + subaddressing_mode preinstruction -> instruction Types.sig0 **) +let realInstruction__o__inject x1 = + RealInstruction x1 + +(** val dpi1__o__RealInstruction : + (subaddressing_mode preinstruction, 'a1) Types.dPair -> instruction **) +let dpi1__o__RealInstruction x1 = + RealInstruction x1.Types.dpi1 + +(** val eject__o__RealInstruction : + subaddressing_mode preinstruction Types.sig0 -> instruction **) +let eject__o__RealInstruction x1 = + RealInstruction (Types.pi1 x1) + +(** val eq_instruction : instruction -> instruction -> Bool.bool **) +let eq_instruction i j = + match i with + | ACALL arg -> + (match j with + | ACALL arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr11, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr11, + Vector.VEmpty)) arg') + | LCALL x -> Bool.False + | AJMP x -> Bool.False + | LJMP x -> Bool.False + | SJMP x -> Bool.False + | MOVC (x, x0) -> Bool.False + | RealInstruction x -> Bool.False) + | LCALL arg -> + (match j with + | ACALL x -> Bool.False + | LCALL arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr16, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr16, + Vector.VEmpty)) arg') + | AJMP x -> Bool.False + | LJMP x -> Bool.False + | SJMP x -> Bool.False + | MOVC (x, x0) -> Bool.False + | RealInstruction x -> Bool.False) + | AJMP arg -> + (match j with + | ACALL x -> Bool.False + | LCALL x -> Bool.False + | AJMP arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr11, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr11, + Vector.VEmpty)) arg') + | LJMP x -> Bool.False + | SJMP x -> Bool.False + | MOVC (x, x0) -> Bool.False + | RealInstruction x -> Bool.False) + | LJMP arg -> + (match j with + | ACALL x -> Bool.False + | LCALL x -> Bool.False + | AJMP x -> Bool.False + | LJMP arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr16, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Addr16, + Vector.VEmpty)) arg') + | SJMP x -> Bool.False + | MOVC (x, x0) -> Bool.False + | RealInstruction x -> Bool.False) + | SJMP arg -> + (match j with + | ACALL x -> Bool.False + | LCALL x -> Bool.False + | AJMP x -> Bool.False + | LJMP x -> Bool.False + | SJMP arg' -> + eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Relative, + Vector.VEmpty)) arg') + | MOVC (x, x0) -> Bool.False + | RealInstruction x -> Bool.False) + | MOVC (arg1, arg2) -> + (match j with + | ACALL x -> Bool.False + | LCALL x -> Bool.False + | AJMP x -> Bool.False + | LJMP x -> Bool.False + | SJMP x -> Bool.False + | MOVC (arg1', arg2') -> + Bool.andb + (eq_addressing_mode + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1) + (subaddressing_modeel Nat.O (Vector.VCons (Nat.O, Acc_a, + Vector.VEmpty)) arg1')) + (eq_addressing_mode + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + Acc_dptr, (Vector.VCons (Nat.O, Acc_pc, Vector.VEmpty)))) arg2) + (subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + Acc_dptr, (Vector.VCons (Nat.O, Acc_pc, Vector.VEmpty)))) arg2')) + | RealInstruction x -> Bool.False) + | RealInstruction instr -> + (match j with + | ACALL x -> Bool.False + | LCALL x -> Bool.False + | AJMP x -> Bool.False + | LJMP x -> Bool.False + | SJMP x -> Bool.False + | MOVC (x, x0) -> Bool.False + | RealInstruction instr' -> eq_preinstruction instr instr') + +type word_side = +| HIGH +| LOW + +(** val word_side_rect_Type4 : 'a1 -> 'a1 -> word_side -> 'a1 **) +let rec word_side_rect_Type4 h_HIGH h_LOW = function +| HIGH -> h_HIGH +| LOW -> h_LOW + +(** val word_side_rect_Type5 : 'a1 -> 'a1 -> word_side -> 'a1 **) +let rec word_side_rect_Type5 h_HIGH h_LOW = function +| HIGH -> h_HIGH +| LOW -> h_LOW + +(** val word_side_rect_Type3 : 'a1 -> 'a1 -> word_side -> 'a1 **) +let rec word_side_rect_Type3 h_HIGH h_LOW = function +| HIGH -> h_HIGH +| LOW -> h_LOW + +(** val word_side_rect_Type2 : 'a1 -> 'a1 -> word_side -> 'a1 **) +let rec word_side_rect_Type2 h_HIGH h_LOW = function +| HIGH -> h_HIGH +| LOW -> h_LOW + +(** val word_side_rect_Type1 : 'a1 -> 'a1 -> word_side -> 'a1 **) +let rec word_side_rect_Type1 h_HIGH h_LOW = function +| HIGH -> h_HIGH +| LOW -> h_LOW + +(** val word_side_rect_Type0 : 'a1 -> 'a1 -> word_side -> 'a1 **) +let rec word_side_rect_Type0 h_HIGH h_LOW = function +| HIGH -> h_HIGH +| LOW -> h_LOW + +(** val word_side_inv_rect_Type4 : + word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let word_side_inv_rect_Type4 hterm h1 h2 = + let hcut = word_side_rect_Type4 h1 h2 hterm in hcut __ + +(** val word_side_inv_rect_Type3 : + word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let word_side_inv_rect_Type3 hterm h1 h2 = + let hcut = word_side_rect_Type3 h1 h2 hterm in hcut __ + +(** val word_side_inv_rect_Type2 : + word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let word_side_inv_rect_Type2 hterm h1 h2 = + let hcut = word_side_rect_Type2 h1 h2 hterm in hcut __ + +(** val word_side_inv_rect_Type1 : + word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let word_side_inv_rect_Type1 hterm h1 h2 = + let hcut = word_side_rect_Type1 h1 h2 hterm in hcut __ + +(** val word_side_inv_rect_Type0 : + word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let word_side_inv_rect_Type0 hterm h1 h2 = + let hcut = word_side_rect_Type0 h1 h2 hterm in hcut __ + +(** val word_side_discr : word_side -> word_side -> __ **) +let word_side_discr x y = + Logic.eq_rect_Type2 x + (match x with + | HIGH -> Obj.magic (fun _ dH -> dH) + | LOW -> Obj.magic (fun _ dH -> dH)) y + +(** val word_side_jmdiscr : word_side -> word_side -> __ **) +let word_side_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | HIGH -> Obj.magic (fun _ dH -> dH) + | LOW -> Obj.magic (fun _ dH -> dH)) y + +type pseudo_instruction = +| Instruction of identifier preinstruction +| Comment of String.string +| Cost of CostLabel.costlabel +| Jmp of identifier +| Jnz of subaddressing_mode * identifier * identifier +| Call of identifier +| Mov of (subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum * identifier * BitVector.word + +(** val pseudo_instruction_rect_Type4 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> + (subaddressing_mode -> identifier -> identifier -> 'a1) -> (identifier -> + 'a1) -> ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction + -> 'a1 **) +let rec pseudo_instruction_rect_Type4 h_Instruction h_Comment h_Cost h_Jmp h_Jnz h_Call h_Mov = function +| Instruction x_21202 -> h_Instruction x_21202 +| Comment x_21203 -> h_Comment x_21203 +| Cost x_21204 -> h_Cost x_21204 +| Jmp x_21205 -> h_Jmp x_21205 +| Jnz (x_21208, x_21207, x_21206) -> h_Jnz x_21208 x_21207 x_21206 +| Call x_21209 -> h_Call x_21209 +| Mov (x_21212, x_21211, x_21210) -> h_Mov x_21212 x_21211 x_21210 + +(** val pseudo_instruction_rect_Type5 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> + (subaddressing_mode -> identifier -> identifier -> 'a1) -> (identifier -> + 'a1) -> ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction + -> 'a1 **) +let rec pseudo_instruction_rect_Type5 h_Instruction h_Comment h_Cost h_Jmp h_Jnz h_Call h_Mov = function +| Instruction x_21221 -> h_Instruction x_21221 +| Comment x_21222 -> h_Comment x_21222 +| Cost x_21223 -> h_Cost x_21223 +| Jmp x_21224 -> h_Jmp x_21224 +| Jnz (x_21227, x_21226, x_21225) -> h_Jnz x_21227 x_21226 x_21225 +| Call x_21228 -> h_Call x_21228 +| Mov (x_21231, x_21230, x_21229) -> h_Mov x_21231 x_21230 x_21229 + +(** val pseudo_instruction_rect_Type3 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> + (subaddressing_mode -> identifier -> identifier -> 'a1) -> (identifier -> + 'a1) -> ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction + -> 'a1 **) +let rec pseudo_instruction_rect_Type3 h_Instruction h_Comment h_Cost h_Jmp h_Jnz h_Call h_Mov = function +| Instruction x_21240 -> h_Instruction x_21240 +| Comment x_21241 -> h_Comment x_21241 +| Cost x_21242 -> h_Cost x_21242 +| Jmp x_21243 -> h_Jmp x_21243 +| Jnz (x_21246, x_21245, x_21244) -> h_Jnz x_21246 x_21245 x_21244 +| Call x_21247 -> h_Call x_21247 +| Mov (x_21250, x_21249, x_21248) -> h_Mov x_21250 x_21249 x_21248 + +(** val pseudo_instruction_rect_Type2 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> + (subaddressing_mode -> identifier -> identifier -> 'a1) -> (identifier -> + 'a1) -> ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction + -> 'a1 **) +let rec pseudo_instruction_rect_Type2 h_Instruction h_Comment h_Cost h_Jmp h_Jnz h_Call h_Mov = function +| Instruction x_21259 -> h_Instruction x_21259 +| Comment x_21260 -> h_Comment x_21260 +| Cost x_21261 -> h_Cost x_21261 +| Jmp x_21262 -> h_Jmp x_21262 +| Jnz (x_21265, x_21264, x_21263) -> h_Jnz x_21265 x_21264 x_21263 +| Call x_21266 -> h_Call x_21266 +| Mov (x_21269, x_21268, x_21267) -> h_Mov x_21269 x_21268 x_21267 + +(** val pseudo_instruction_rect_Type1 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> + (subaddressing_mode -> identifier -> identifier -> 'a1) -> (identifier -> + 'a1) -> ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction + -> 'a1 **) +let rec pseudo_instruction_rect_Type1 h_Instruction h_Comment h_Cost h_Jmp h_Jnz h_Call h_Mov = function +| Instruction x_21278 -> h_Instruction x_21278 +| Comment x_21279 -> h_Comment x_21279 +| Cost x_21280 -> h_Cost x_21280 +| Jmp x_21281 -> h_Jmp x_21281 +| Jnz (x_21284, x_21283, x_21282) -> h_Jnz x_21284 x_21283 x_21282 +| Call x_21285 -> h_Call x_21285 +| Mov (x_21288, x_21287, x_21286) -> h_Mov x_21288 x_21287 x_21286 + +(** val pseudo_instruction_rect_Type0 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> + (subaddressing_mode -> identifier -> identifier -> 'a1) -> (identifier -> + 'a1) -> ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction + -> 'a1 **) +let rec pseudo_instruction_rect_Type0 h_Instruction h_Comment h_Cost h_Jmp h_Jnz h_Call h_Mov = function +| Instruction x_21297 -> h_Instruction x_21297 +| Comment x_21298 -> h_Comment x_21298 +| Cost x_21299 -> h_Cost x_21299 +| Jmp x_21300 -> h_Jmp x_21300 +| Jnz (x_21303, x_21302, x_21301) -> h_Jnz x_21303 x_21302 x_21301 +| Call x_21304 -> h_Call x_21304 +| Mov (x_21307, x_21306, x_21305) -> h_Mov x_21307 x_21306 x_21305 + +(** val pseudo_instruction_inv_rect_Type4 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 **) +let pseudo_instruction_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = pseudo_instruction_rect_Type4 h1 h2 h3 h4 h5 h6 h7 hterm in + hcut __ + +(** val pseudo_instruction_inv_rect_Type3 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 **) +let pseudo_instruction_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = pseudo_instruction_rect_Type3 h1 h2 h3 h4 h5 h6 h7 hterm in + hcut __ + +(** val pseudo_instruction_inv_rect_Type2 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 **) +let pseudo_instruction_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = pseudo_instruction_rect_Type2 h1 h2 h3 h4 h5 h6 h7 hterm in + hcut __ + +(** val pseudo_instruction_inv_rect_Type1 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 **) +let pseudo_instruction_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = pseudo_instruction_rect_Type1 h1 h2 h3 h4 h5 h6 h7 hterm in + hcut __ + +(** val pseudo_instruction_inv_rect_Type0 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 **) +let pseudo_instruction_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = pseudo_instruction_rect_Type0 h1 h2 h3 h4 h5 h6 h7 hterm in + hcut __ + +(** val pseudo_instruction_discr : + pseudo_instruction -> pseudo_instruction -> __ **) +let pseudo_instruction_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Instruction a0 -> Obj.magic (fun _ dH -> dH __) + | Comment a0 -> Obj.magic (fun _ dH -> dH __) + | Cost a0 -> Obj.magic (fun _ dH -> dH __) + | Jmp a0 -> Obj.magic (fun _ dH -> dH __) + | Jnz (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Call a0 -> Obj.magic (fun _ dH -> dH __) + | Mov (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val pseudo_instruction_jmdiscr : + pseudo_instruction -> pseudo_instruction -> __ **) +let pseudo_instruction_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Instruction a0 -> Obj.magic (fun _ dH -> dH __) + | Comment a0 -> Obj.magic (fun _ dH -> dH __) + | Cost a0 -> Obj.magic (fun _ dH -> dH __) + | Jmp a0 -> Obj.magic (fun _ dH -> dH __) + | Jnz (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Call a0 -> Obj.magic (fun _ dH -> dH __) + | Mov (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +type labelled_instruction = pseudo_instruction LabelledObjects.labelled_obj + +type assembly_program = instruction List.list + +(** val fetch_pseudo_instruction : + labelled_instruction List.list -> BitVector.word -> (pseudo_instruction, + BitVector.word) Types.prod **) +let fetch_pseudo_instruction code_mem pc = + let { Types.fst = lbl; Types.snd = instr } = + Util.nth_safe + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) pc) code_mem + in + let new_pc = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) pc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.S Nat.O)) + in + { Types.fst = instr; Types.snd = new_pc } + +(** val is_jump' : identifier preinstruction -> Bool.bool **) +let is_jump' = function +| ADD (x0, x1) -> Bool.False +| ADDC (x0, x1) -> Bool.False +| SUBB (x0, x1) -> Bool.False +| INC x0 -> Bool.False +| DEC x0 -> Bool.False +| MUL (x0, x1) -> Bool.False +| DIV (x0, x1) -> Bool.False +| DA x0 -> Bool.False +| JC x0 -> Bool.True +| JNC x0 -> Bool.True +| JB (x0, x1) -> Bool.True +| JNB (x0, x1) -> Bool.True +| JBC (x0, x1) -> Bool.True +| JZ x0 -> Bool.True +| JNZ x0 -> Bool.True +| CJNE (x0, x1) -> Bool.True +| DJNZ (x0, x1) -> Bool.True +| ANL x0 -> Bool.False +| ORL x0 -> Bool.False +| XRL x0 -> Bool.False +| CLR x0 -> Bool.False +| CPL x0 -> Bool.False +| RL x0 -> Bool.False +| RLC x0 -> Bool.False +| RR x0 -> Bool.False +| RRC x0 -> Bool.False +| SWAP x0 -> Bool.False +| MOV x0 -> Bool.False +| MOVX x0 -> Bool.False +| SETB x0 -> Bool.False +| PUSH x0 -> Bool.False +| POP x0 -> Bool.False +| XCH (x0, x1) -> Bool.False +| XCHD (x0, x1) -> Bool.False +| RET -> Bool.False +| RETI -> Bool.False +| NOP -> Bool.False +| JMP x0 -> Bool.False + +(** val is_relative_jump : pseudo_instruction -> Bool.bool **) +let is_relative_jump = function +| Instruction i -> is_jump' i +| Comment x -> Bool.False +| Cost x -> Bool.False +| Jmp x -> Bool.False +| Jnz (x, x0, x1) -> Bool.False +| Call x -> Bool.False +| Mov (x, x0, x1) -> Bool.False + +(** val is_jump : pseudo_instruction -> Bool.bool **) +let is_jump = function +| Instruction i -> is_jump' i +| Comment x -> Bool.False +| Cost x -> Bool.False +| Jmp x -> Bool.True +| Jnz (x, x0, x1) -> Bool.False +| Call x -> Bool.True +| Mov (x, x0, x1) -> Bool.False + +(** val is_call : pseudo_instruction -> Bool.bool **) +let is_call = function +| Instruction x -> Bool.False +| Comment x -> Bool.False +| Cost x -> Bool.False +| Jmp x -> Bool.False +| Jnz (x, x0, x1) -> Bool.False +| Call x -> Bool.True +| Mov (x, x0, x1) -> Bool.False + +(** val asm_cost_label : + labelled_instruction List.list -> BitVector.word Types.sig0 -> + CostLabel.costlabel Types.option **) +let asm_cost_label mem w_prf = + match (fetch_pseudo_instruction mem (Types.pi1 w_prf)).Types.fst with + | Instruction x -> Types.None + | Comment x -> Types.None + | Cost c -> Types.Some c + | Jmp x -> Types.None + | Jnz (x, x0, x1) -> Types.None + | Call x -> Types.None + | Mov (x, x0, x1) -> Types.None + +(** val aDDRESS_WIDTH : Nat.nat **) +let aDDRESS_WIDTH = + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))) + +(** val mAX_CODE_SIZE : Nat.nat **) +let mAX_CODE_SIZE = + Exp.exp (Nat.S (Nat.S Nat.O)) aDDRESS_WIDTH + +(** val code_size_opt : labelled_instruction List.list -> __ Types.option **) +let code_size_opt code = + Extranat.nat_bound_opt mAX_CODE_SIZE (Nat.S (List.length code)) + +type pseudo_assembly_program = { preamble : (identifier, BitVector.word) + Types.prod List.list; + code : labelled_instruction List.list; + renamed_symbols : (identifier, AST.ident) + Types.prod List.list; + final_label : identifier } + +(** val pseudo_assembly_program_rect_Type4 : + ((identifier, BitVector.word) Types.prod List.list -> + labelled_instruction List.list -> __ -> (identifier, AST.ident) + Types.prod List.list -> identifier -> __ -> __ -> 'a1) -> + pseudo_assembly_program -> 'a1 **) +let rec pseudo_assembly_program_rect_Type4 h_mk_pseudo_assembly_program x_21431 = + let { preamble = preamble0; code = code0; renamed_symbols = + renamed_symbols0; final_label = final_label0 } = x_21431 + in + h_mk_pseudo_assembly_program preamble0 code0 __ renamed_symbols0 + final_label0 __ __ + +(** val pseudo_assembly_program_rect_Type5 : + ((identifier, BitVector.word) Types.prod List.list -> + labelled_instruction List.list -> __ -> (identifier, AST.ident) + Types.prod List.list -> identifier -> __ -> __ -> 'a1) -> + pseudo_assembly_program -> 'a1 **) +let rec pseudo_assembly_program_rect_Type5 h_mk_pseudo_assembly_program x_21433 = + let { preamble = preamble0; code = code0; renamed_symbols = + renamed_symbols0; final_label = final_label0 } = x_21433 + in + h_mk_pseudo_assembly_program preamble0 code0 __ renamed_symbols0 + final_label0 __ __ + +(** val pseudo_assembly_program_rect_Type3 : + ((identifier, BitVector.word) Types.prod List.list -> + labelled_instruction List.list -> __ -> (identifier, AST.ident) + Types.prod List.list -> identifier -> __ -> __ -> 'a1) -> + pseudo_assembly_program -> 'a1 **) +let rec pseudo_assembly_program_rect_Type3 h_mk_pseudo_assembly_program x_21435 = + let { preamble = preamble0; code = code0; renamed_symbols = + renamed_symbols0; final_label = final_label0 } = x_21435 + in + h_mk_pseudo_assembly_program preamble0 code0 __ renamed_symbols0 + final_label0 __ __ + +(** val pseudo_assembly_program_rect_Type2 : + ((identifier, BitVector.word) Types.prod List.list -> + labelled_instruction List.list -> __ -> (identifier, AST.ident) + Types.prod List.list -> identifier -> __ -> __ -> 'a1) -> + pseudo_assembly_program -> 'a1 **) +let rec pseudo_assembly_program_rect_Type2 h_mk_pseudo_assembly_program x_21437 = + let { preamble = preamble0; code = code0; renamed_symbols = + renamed_symbols0; final_label = final_label0 } = x_21437 + in + h_mk_pseudo_assembly_program preamble0 code0 __ renamed_symbols0 + final_label0 __ __ + +(** val pseudo_assembly_program_rect_Type1 : + ((identifier, BitVector.word) Types.prod List.list -> + labelled_instruction List.list -> __ -> (identifier, AST.ident) + Types.prod List.list -> identifier -> __ -> __ -> 'a1) -> + pseudo_assembly_program -> 'a1 **) +let rec pseudo_assembly_program_rect_Type1 h_mk_pseudo_assembly_program x_21439 = + let { preamble = preamble0; code = code0; renamed_symbols = + renamed_symbols0; final_label = final_label0 } = x_21439 + in + h_mk_pseudo_assembly_program preamble0 code0 __ renamed_symbols0 + final_label0 __ __ + +(** val pseudo_assembly_program_rect_Type0 : + ((identifier, BitVector.word) Types.prod List.list -> + labelled_instruction List.list -> __ -> (identifier, AST.ident) + Types.prod List.list -> identifier -> __ -> __ -> 'a1) -> + pseudo_assembly_program -> 'a1 **) +let rec pseudo_assembly_program_rect_Type0 h_mk_pseudo_assembly_program x_21441 = + let { preamble = preamble0; code = code0; renamed_symbols = + renamed_symbols0; final_label = final_label0 } = x_21441 + in + h_mk_pseudo_assembly_program preamble0 code0 __ renamed_symbols0 + final_label0 __ __ + +(** val preamble : + pseudo_assembly_program -> (identifier, BitVector.word) Types.prod + List.list **) +let rec preamble xxx = + xxx.preamble + +(** val code : pseudo_assembly_program -> labelled_instruction List.list **) +let rec code xxx = + xxx.code + +(** val renamed_symbols : + pseudo_assembly_program -> (identifier, AST.ident) Types.prod List.list **) +let rec renamed_symbols xxx = + xxx.renamed_symbols + +(** val final_label : pseudo_assembly_program -> identifier **) +let rec final_label xxx = + xxx.final_label + +(** val pseudo_assembly_program_inv_rect_Type4 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) + -> 'a1 **) +let pseudo_assembly_program_inv_rect_Type4 hterm h1 = + let hcut = pseudo_assembly_program_rect_Type4 h1 hterm in hcut __ + +(** val pseudo_assembly_program_inv_rect_Type3 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) + -> 'a1 **) +let pseudo_assembly_program_inv_rect_Type3 hterm h1 = + let hcut = pseudo_assembly_program_rect_Type3 h1 hterm in hcut __ + +(** val pseudo_assembly_program_inv_rect_Type2 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) + -> 'a1 **) +let pseudo_assembly_program_inv_rect_Type2 hterm h1 = + let hcut = pseudo_assembly_program_rect_Type2 h1 hterm in hcut __ + +(** val pseudo_assembly_program_inv_rect_Type1 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) + -> 'a1 **) +let pseudo_assembly_program_inv_rect_Type1 hterm h1 = + let hcut = pseudo_assembly_program_rect_Type1 h1 hterm in hcut __ + +(** val pseudo_assembly_program_inv_rect_Type0 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) + -> 'a1 **) +let pseudo_assembly_program_inv_rect_Type0 hterm h1 = + let hcut = pseudo_assembly_program_rect_Type0 h1 hterm in hcut __ + +(** val pseudo_assembly_program_jmdiscr : + pseudo_assembly_program -> pseudo_assembly_program -> __ **) +let pseudo_assembly_program_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { preamble = a0; code = a1; renamed_symbols = a3; final_label = + a4 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) y + +type object_code = BitVector.byte List.list + +(** val next : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + (BitVector.word, BitVector.byte) Types.prod **) +let next pmem pc = + { Types.fst = + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) pc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.S Nat.O))); Types.snd = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) pc pmem + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) } + +(** val load_code_memory0 : + object_code -> BitVector.byte BitVectorTrie.bitVectorTrie Types.sig0 **) +let load_code_memory0 program = + (Types.pi1 + (FoldStuff.foldl_strong program (fun prefix v tl _ i_mem -> + (let { Types.fst = i; Types.snd = mem } = Types.pi1 i_mem in + (fun _ -> { Types.fst = (Nat.S i); Types.snd = + (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) i) v mem) })) __) { Types.fst = + Nat.O; Types.snd = (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))))))))))) })).Types.snd + +(** val load_code_memory : + object_code -> BitVector.byte BitVectorTrie.bitVectorTrie **) +let load_code_memory program = + Types.pi1 (load_code_memory0 program) + +type costlabel_map = CostLabel.costlabel BitVectorTrie.bitVectorTrie + +type symboltable_type = AST.ident BitVectorTrie.bitVectorTrie + +type labelled_object_code = { oc : object_code; + cm : BitVector.byte BitVectorTrie.bitVectorTrie; + costlabels : costlabel_map; + symboltable : symboltable_type; + final_pc : BitVector.word } + +(** val labelled_object_code_rect_Type4 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 **) +let rec labelled_object_code_rect_Type4 h_mk_labelled_object_code x_21457 = + let { oc = oc0; cm = cm0; costlabels = costlabels0; symboltable = + symboltable0; final_pc = final_pc0 } = x_21457 + in + h_mk_labelled_object_code oc0 cm0 __ costlabels0 symboltable0 final_pc0 __ + +(** val labelled_object_code_rect_Type5 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 **) +let rec labelled_object_code_rect_Type5 h_mk_labelled_object_code x_21459 = + let { oc = oc0; cm = cm0; costlabels = costlabels0; symboltable = + symboltable0; final_pc = final_pc0 } = x_21459 + in + h_mk_labelled_object_code oc0 cm0 __ costlabels0 symboltable0 final_pc0 __ + +(** val labelled_object_code_rect_Type3 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 **) +let rec labelled_object_code_rect_Type3 h_mk_labelled_object_code x_21461 = + let { oc = oc0; cm = cm0; costlabels = costlabels0; symboltable = + symboltable0; final_pc = final_pc0 } = x_21461 + in + h_mk_labelled_object_code oc0 cm0 __ costlabels0 symboltable0 final_pc0 __ + +(** val labelled_object_code_rect_Type2 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 **) +let rec labelled_object_code_rect_Type2 h_mk_labelled_object_code x_21463 = + let { oc = oc0; cm = cm0; costlabels = costlabels0; symboltable = + symboltable0; final_pc = final_pc0 } = x_21463 + in + h_mk_labelled_object_code oc0 cm0 __ costlabels0 symboltable0 final_pc0 __ + +(** val labelled_object_code_rect_Type1 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 **) +let rec labelled_object_code_rect_Type1 h_mk_labelled_object_code x_21465 = + let { oc = oc0; cm = cm0; costlabels = costlabels0; symboltable = + symboltable0; final_pc = final_pc0 } = x_21465 + in + h_mk_labelled_object_code oc0 cm0 __ costlabels0 symboltable0 final_pc0 __ + +(** val labelled_object_code_rect_Type0 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 **) +let rec labelled_object_code_rect_Type0 h_mk_labelled_object_code x_21467 = + let { oc = oc0; cm = cm0; costlabels = costlabels0; symboltable = + symboltable0; final_pc = final_pc0 } = x_21467 + in + h_mk_labelled_object_code oc0 cm0 __ costlabels0 symboltable0 final_pc0 __ + +(** val oc : labelled_object_code -> object_code **) +let rec oc xxx = + xxx.oc + +(** val cm : + labelled_object_code -> BitVector.byte BitVectorTrie.bitVectorTrie **) +let rec cm xxx = + xxx.cm + +(** val costlabels : labelled_object_code -> costlabel_map **) +let rec costlabels xxx = + xxx.costlabels + +(** val symboltable : labelled_object_code -> symboltable_type **) +let rec symboltable xxx = + xxx.symboltable + +(** val final_pc : labelled_object_code -> BitVector.word **) +let rec final_pc xxx = + xxx.final_pc + +(** val labelled_object_code_inv_rect_Type4 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 **) +let labelled_object_code_inv_rect_Type4 hterm h1 = + let hcut = labelled_object_code_rect_Type4 h1 hterm in hcut __ + +(** val labelled_object_code_inv_rect_Type3 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 **) +let labelled_object_code_inv_rect_Type3 hterm h1 = + let hcut = labelled_object_code_rect_Type3 h1 hterm in hcut __ + +(** val labelled_object_code_inv_rect_Type2 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 **) +let labelled_object_code_inv_rect_Type2 hterm h1 = + let hcut = labelled_object_code_rect_Type2 h1 hterm in hcut __ + +(** val labelled_object_code_inv_rect_Type1 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 **) +let labelled_object_code_inv_rect_Type1 hterm h1 = + let hcut = labelled_object_code_rect_Type1 h1 hterm in hcut __ + +(** val labelled_object_code_inv_rect_Type0 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 **) +let labelled_object_code_inv_rect_Type0 hterm h1 = + let hcut = labelled_object_code_rect_Type0 h1 hterm in hcut __ + +(** val labelled_object_code_jmdiscr : + labelled_object_code -> labelled_object_code -> __ **) +let labelled_object_code_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { oc = a0; cm = a1; costlabels = a3; symboltable = a4; final_pc = + a5 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) y + diff --git a/extracted/aSM.mli b/extracted/aSM.mli new file mode 100644 index 0000000..7b37401 --- /dev/null +++ b/extracted/aSM.mli @@ -0,0 +1,1377 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open LabelledObjects + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open String + +open BitVectorTrie + +type identifier = PreIdentifiers.identifier + +val toASM_ident : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> identifier + +type addressing_mode = +| DIRECT of BitVector.byte +| INDIRECT of BitVector.bit +| EXT_INDIRECT of BitVector.bit +| REGISTER of BitVector.bitVector +| ACC_A +| ACC_B +| DPTR +| DATA of BitVector.byte +| DATA16 of BitVector.word +| ACC_DPTR +| ACC_PC +| EXT_INDIRECT_DPTR +| INDIRECT_DPTR +| CARRY +| BIT_ADDR of BitVector.byte +| N_BIT_ADDR of BitVector.byte +| RELATIVE of BitVector.byte +| ADDR11 of BitVector.word11 +| ADDR16 of BitVector.word + +val addressing_mode_rect_Type4 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> 'a1) + -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> (BitVector.byte -> + 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (BitVector.byte -> + 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word -> 'a1) -> + addressing_mode -> 'a1 + +val addressing_mode_rect_Type5 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> 'a1) + -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> (BitVector.byte -> + 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (BitVector.byte -> + 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word -> 'a1) -> + addressing_mode -> 'a1 + +val addressing_mode_rect_Type3 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> 'a1) + -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> (BitVector.byte -> + 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (BitVector.byte -> + 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word -> 'a1) -> + addressing_mode -> 'a1 + +val addressing_mode_rect_Type2 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> 'a1) + -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> (BitVector.byte -> + 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (BitVector.byte -> + 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word -> 'a1) -> + addressing_mode -> 'a1 + +val addressing_mode_rect_Type1 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> 'a1) + -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> (BitVector.byte -> + 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (BitVector.byte -> + 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word -> 'a1) -> + addressing_mode -> 'a1 + +val addressing_mode_rect_Type0 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> 'a1) -> (BitVector.bit -> 'a1) + -> (BitVector.bitVector -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> (BitVector.byte -> + 'a1) -> (BitVector.word -> 'a1) -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (BitVector.byte -> + 'a1) -> (BitVector.word11 -> 'a1) -> (BitVector.word -> 'a1) -> + addressing_mode -> 'a1 + +val addressing_mode_inv_rect_Type4 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ -> + 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 + +val addressing_mode_inv_rect_Type3 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ -> + 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 + +val addressing_mode_inv_rect_Type2 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ -> + 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 + +val addressing_mode_inv_rect_Type1 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ -> + 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 + +val addressing_mode_inv_rect_Type0 : + addressing_mode -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> __ -> + 'a1) -> (BitVector.bit -> __ -> 'a1) -> (BitVector.bitVector -> __ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (BitVector.word -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) -> + (BitVector.word11 -> __ -> 'a1) -> (BitVector.word -> __ -> 'a1) -> 'a1 + +val addressing_mode_discr : addressing_mode -> addressing_mode -> __ + +val addressing_mode_jmdiscr : addressing_mode -> addressing_mode -> __ + +val eq_addressing_mode : addressing_mode -> addressing_mode -> Bool.bool + +type addressing_mode_tag = +| Direct +| Indirect +| Ext_indirect +| Registr +| Acc_a +| Acc_b +| Dptr +| Data +| Data16 +| Acc_dptr +| Acc_pc +| Ext_indirect_dptr +| Indirect_dptr +| Carry +| Bit_addr +| N_bit_addr +| Relative +| Addr11 +| Addr16 + +val addressing_mode_tag_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 + +val addressing_mode_tag_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 + +val addressing_mode_tag_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 + +val addressing_mode_tag_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 + +val addressing_mode_tag_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 + +val addressing_mode_tag_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + addressing_mode_tag -> 'a1 + +val addressing_mode_tag_inv_rect_Type4 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val addressing_mode_tag_inv_rect_Type3 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val addressing_mode_tag_inv_rect_Type2 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val addressing_mode_tag_inv_rect_Type1 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val addressing_mode_tag_inv_rect_Type0 : + addressing_mode_tag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val addressing_mode_tag_discr : + addressing_mode_tag -> addressing_mode_tag -> __ + +val addressing_mode_tag_jmdiscr : + addressing_mode_tag -> addressing_mode_tag -> __ + +val eq_a : addressing_mode_tag -> addressing_mode_tag -> Bool.bool + +val is_a : addressing_mode_tag -> addressing_mode -> Bool.bool + +val is_in : + Nat.nat -> addressing_mode_tag Vector.vector -> addressing_mode -> + Bool.bool + +type subaddressing_mode = + addressing_mode + (* singleton inductive, whose constructor was mk_subaddressing_mode *) + +val subaddressing_mode_rect_Type4 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 + +val subaddressing_mode_rect_Type5 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 + +val subaddressing_mode_rect_Type3 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 + +val subaddressing_mode_rect_Type2 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 + +val subaddressing_mode_rect_Type1 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 + +val subaddressing_mode_rect_Type0 : + Nat.nat -> addressing_mode_tag Vector.vector -> (addressing_mode -> __ -> + 'a1) -> subaddressing_mode -> 'a1 + +val subaddressing_modeel : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + addressing_mode + +val subaddressing_mode_inv_rect_Type4 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 + +val subaddressing_mode_inv_rect_Type3 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 + +val subaddressing_mode_inv_rect_Type2 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 + +val subaddressing_mode_inv_rect_Type1 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 + +val subaddressing_mode_inv_rect_Type0 : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + (addressing_mode -> __ -> __ -> 'a1) -> 'a1 + +val subaddressing_mode_discr : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode -> __ + +val subaddressing_mode_jmdiscr : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode -> __ + +val dpi1__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> addressing_mode Types.sig0 + +val eject__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode + Types.sig0 -> addressing_mode Types.sig0 + +val subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode -> + addressing_mode Types.sig0 + +val dpi1__o__subaddressing_modeel : + Nat.nat -> addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) + Types.dPair -> addressing_mode + +val eject__o__subaddressing_modeel : + Nat.nat -> addressing_mode_tag Vector.vector -> subaddressing_mode + Types.sig0 -> addressing_mode + +type 'x1 dpi1__o__subaddressing_mode = subaddressing_mode + +type eject__o__subaddressing_mode = subaddressing_mode + +val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) Types.dPair + -> subaddressing_mode Types.sig0 + +val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) Types.dPair + -> addressing_mode Types.sig0 + +val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) Types.dPair + -> addressing_mode + +val eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + subaddressing_mode Types.sig0 + +val eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + addressing_mode Types.sig0 + +val eject__o__subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + addressing_mode + +val subaddressing_modeel__o__mk_subaddressing_mode__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode Types.sig0 + +val subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> addressing_mode + Types.sig0 + +val subaddressing_modeel__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> addressing_mode + +val dpi1__o__mk_subaddressing_mode__o__inject : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> subaddressing_mode Types.sig0 + +val dpi1__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> addressing_mode Types.sig0 + +val dpi1__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> addressing_mode + +val eject__o__mk_subaddressing_mode__o__inject : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag Vector.vector + -> subaddressing_mode Types.sig0 + +val eject__o__mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag Vector.vector + -> addressing_mode Types.sig0 + +val eject__o__mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag Vector.vector + -> addressing_mode + +val mk_subaddressing_mode__o__subaddressing_modeel : + Nat.nat -> addressing_mode -> addressing_mode_tag Vector.vector -> + addressing_mode + +val mk_subaddressing_mode__o__subaddressing_modeel__o__inject : + Nat.nat -> addressing_mode -> addressing_mode_tag Vector.vector -> + addressing_mode Types.sig0 + +val mk_subaddressing_mode__o__inject : + Nat.nat -> addressing_mode -> addressing_mode_tag Vector.vector -> + subaddressing_mode Types.sig0 + +val dpi1__o__subaddressing_modeel__o__mk_subaddressing_mode : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> (subaddressing_mode, 'a1) Types.dPair + -> subaddressing_mode + +val eject__o__subaddressing_modeel__o__mk_subaddressing_mode : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode Types.sig0 -> + subaddressing_mode + +val subaddressing_modeel__o__mk_subaddressing_mode : + Nat.nat -> Nat.nat -> addressing_mode_tag Vector.vector -> + addressing_mode_tag Vector.vector -> subaddressing_mode -> + subaddressing_mode + +val dpi1__o__mk_subaddressing_mode : + Nat.nat -> (addressing_mode, 'a1) Types.dPair -> addressing_mode_tag + Vector.vector -> subaddressing_mode + +val eject__o__mk_subaddressing_mode : + Nat.nat -> addressing_mode Types.sig0 -> addressing_mode_tag Vector.vector + -> subaddressing_mode + +type 'a preinstruction = +| ADD of subaddressing_mode * subaddressing_mode +| ADDC of subaddressing_mode * subaddressing_mode +| SUBB of subaddressing_mode * subaddressing_mode +| INC of subaddressing_mode +| DEC of subaddressing_mode +| MUL of subaddressing_mode * subaddressing_mode +| DIV of subaddressing_mode * subaddressing_mode +| DA of subaddressing_mode +| JC of 'a +| JNC of 'a +| JB of subaddressing_mode * 'a +| JNB of subaddressing_mode * 'a +| JBC of subaddressing_mode * 'a +| JZ of 'a +| JNZ of 'a +| CJNE of ((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum * + 'a +| DJNZ of subaddressing_mode * 'a +| ANL of (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| ORL of (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| XRL of ((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| CLR of subaddressing_mode +| CPL of subaddressing_mode +| RL of subaddressing_mode +| RLC of subaddressing_mode +| RR of subaddressing_mode +| RRC of subaddressing_mode +| SWAP of subaddressing_mode +| MOV of ((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| MOVX of ((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum +| SETB of subaddressing_mode +| PUSH of subaddressing_mode +| POP of subaddressing_mode +| XCH of subaddressing_mode * subaddressing_mode +| XCHD of subaddressing_mode * subaddressing_mode +| RET +| RETI +| NOP +| JMP of subaddressing_mode + +val preinstruction_rect_Type4 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) + -> ('a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ('a1 -> 'a2) -> ('a1 -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> 'a2 -> 'a2 -> 'a2 -> (subaddressing_mode -> + 'a2) -> 'a1 preinstruction -> 'a2 + +val preinstruction_rect_Type5 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) + -> ('a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ('a1 -> 'a2) -> ('a1 -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> 'a2 -> 'a2 -> 'a2 -> (subaddressing_mode -> + 'a2) -> 'a1 preinstruction -> 'a2 + +val preinstruction_rect_Type3 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) + -> ('a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ('a1 -> 'a2) -> ('a1 -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> 'a2 -> 'a2 -> 'a2 -> (subaddressing_mode -> + 'a2) -> 'a1 preinstruction -> 'a2 + +val preinstruction_rect_Type2 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) + -> ('a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ('a1 -> 'a2) -> ('a1 -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> 'a2 -> 'a2 -> 'a2 -> (subaddressing_mode -> + 'a2) -> 'a1 preinstruction -> 'a2 + +val preinstruction_rect_Type1 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) + -> ('a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ('a1 -> 'a2) -> ('a1 -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> 'a2 -> 'a2 -> 'a2 -> (subaddressing_mode -> + 'a2) -> 'a1 preinstruction -> 'a2 + +val preinstruction_rect_Type0 : + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> ('a1 -> 'a2) + -> ('a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + (subaddressing_mode -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ('a1 -> 'a2) -> ('a1 -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> 'a2) -> (subaddressing_mode -> 'a1 -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (((((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> 'a2) -> + (((subaddressing_mode, subaddressing_mode) Types.prod, (subaddressing_mode, + subaddressing_mode) Types.prod) Types.sum -> 'a2) -> (subaddressing_mode -> + 'a2) -> (subaddressing_mode -> 'a2) -> (subaddressing_mode -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> 'a2) -> 'a2 -> 'a2 -> 'a2 -> (subaddressing_mode -> + 'a2) -> 'a1 preinstruction -> 'a2 + +val preinstruction_inv_rect_Type4 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> + 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 -> __ + -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) + Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> (__ -> 'a2) -> (__ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 + +val preinstruction_inv_rect_Type3 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> + 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 -> __ + -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) + Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> (__ -> 'a2) -> (__ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 + +val preinstruction_inv_rect_Type2 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> + 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 -> __ + -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) + Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> (__ -> 'a2) -> (__ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 + +val preinstruction_inv_rect_Type1 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> + 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 -> __ + -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) + Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> (__ -> 'a2) -> (__ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 + +val preinstruction_inv_rect_Type0 : + 'a1 preinstruction -> (subaddressing_mode -> subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> subaddressing_mode -> __ -> 'a2) -> + (subaddressing_mode -> __ -> 'a2) -> ('a1 -> __ -> 'a2) -> ('a1 -> __ -> + 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> + 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> ('a1 -> __ + -> 'a2) -> ('a1 -> __ -> 'a2) -> (((subaddressing_mode, subaddressing_mode) + Types.prod, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum + -> 'a1 -> __ -> 'a2) -> (subaddressing_mode -> 'a1 -> __ -> 'a2) -> + ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> ((((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (((((((subaddressing_mode, + subaddressing_mode) Types.prod, (subaddressing_mode, subaddressing_mode) + Types.prod) Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) + Types.sum, (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (((subaddressing_mode, subaddressing_mode) Types.prod, + (subaddressing_mode, subaddressing_mode) Types.prod) Types.sum -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> __ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a2) -> (__ -> 'a2) -> (__ -> 'a2) -> (__ -> + 'a2) -> (subaddressing_mode -> __ -> 'a2) -> 'a2 + +val preinstruction_discr : 'a1 preinstruction -> 'a1 preinstruction -> __ + +val preinstruction_jmdiscr : 'a1 preinstruction -> 'a1 preinstruction -> __ + +val eq_preinstruction : + subaddressing_mode preinstruction -> subaddressing_mode preinstruction -> + Bool.bool + +type instruction = +| ACALL of subaddressing_mode +| LCALL of subaddressing_mode +| AJMP of subaddressing_mode +| LJMP of subaddressing_mode +| SJMP of subaddressing_mode +| MOVC of subaddressing_mode * subaddressing_mode +| RealInstruction of subaddressing_mode preinstruction + +val instruction_rect_Type4 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode -> + 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> 'a1 + +val instruction_rect_Type5 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode -> + 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> 'a1 + +val instruction_rect_Type3 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode -> + 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> 'a1 + +val instruction_rect_Type2 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode -> + 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> 'a1 + +val instruction_rect_Type1 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode -> + 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> 'a1 + +val instruction_rect_Type0 : + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> 'a1) -> + (subaddressing_mode -> 'a1) -> (subaddressing_mode -> subaddressing_mode -> + 'a1) -> (subaddressing_mode preinstruction -> 'a1) -> instruction -> 'a1 + +val instruction_inv_rect_Type4 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction -> + __ -> 'a1) -> 'a1 + +val instruction_inv_rect_Type3 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction -> + __ -> 'a1) -> 'a1 + +val instruction_inv_rect_Type2 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction -> + __ -> 'a1) -> 'a1 + +val instruction_inv_rect_Type1 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction -> + __ -> 'a1) -> 'a1 + +val instruction_inv_rect_Type0 : + instruction -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + __ -> 'a1) -> (subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode -> + subaddressing_mode -> __ -> 'a1) -> (subaddressing_mode preinstruction -> + __ -> 'a1) -> 'a1 + +val instruction_discr : instruction -> instruction -> __ + +val instruction_jmdiscr : instruction -> instruction -> __ + +val dpi1__o__RealInstruction__o__inject : + (subaddressing_mode preinstruction, 'a1) Types.dPair -> instruction + Types.sig0 + +val eject__o__RealInstruction__o__inject : + subaddressing_mode preinstruction Types.sig0 -> instruction Types.sig0 + +val realInstruction__o__inject : + subaddressing_mode preinstruction -> instruction Types.sig0 + +val dpi1__o__RealInstruction : + (subaddressing_mode preinstruction, 'a1) Types.dPair -> instruction + +val eject__o__RealInstruction : + subaddressing_mode preinstruction Types.sig0 -> instruction + +val eq_instruction : instruction -> instruction -> Bool.bool + +type word_side = +| HIGH +| LOW + +val word_side_rect_Type4 : 'a1 -> 'a1 -> word_side -> 'a1 + +val word_side_rect_Type5 : 'a1 -> 'a1 -> word_side -> 'a1 + +val word_side_rect_Type3 : 'a1 -> 'a1 -> word_side -> 'a1 + +val word_side_rect_Type2 : 'a1 -> 'a1 -> word_side -> 'a1 + +val word_side_rect_Type1 : 'a1 -> 'a1 -> word_side -> 'a1 + +val word_side_rect_Type0 : 'a1 -> 'a1 -> word_side -> 'a1 + +val word_side_inv_rect_Type4 : word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val word_side_inv_rect_Type3 : word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val word_side_inv_rect_Type2 : word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val word_side_inv_rect_Type1 : word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val word_side_inv_rect_Type0 : word_side -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val word_side_discr : word_side -> word_side -> __ + +val word_side_jmdiscr : word_side -> word_side -> __ + +type pseudo_instruction = +| Instruction of identifier preinstruction +| Comment of String.string +| Cost of CostLabel.costlabel +| Jmp of identifier +| Jnz of subaddressing_mode * identifier * identifier +| Call of identifier +| Mov of (subaddressing_mode, (subaddressing_mode, word_side) Types.prod) + Types.sum * identifier * BitVector.word + +val pseudo_instruction_rect_Type4 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> (subaddressing_mode + -> identifier -> identifier -> 'a1) -> (identifier -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction -> 'a1 + +val pseudo_instruction_rect_Type5 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> (subaddressing_mode + -> identifier -> identifier -> 'a1) -> (identifier -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction -> 'a1 + +val pseudo_instruction_rect_Type3 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> (subaddressing_mode + -> identifier -> identifier -> 'a1) -> (identifier -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction -> 'a1 + +val pseudo_instruction_rect_Type2 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> (subaddressing_mode + -> identifier -> identifier -> 'a1) -> (identifier -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction -> 'a1 + +val pseudo_instruction_rect_Type1 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> (subaddressing_mode + -> identifier -> identifier -> 'a1) -> (identifier -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction -> 'a1 + +val pseudo_instruction_rect_Type0 : + (identifier preinstruction -> 'a1) -> (String.string -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (identifier -> 'a1) -> (subaddressing_mode + -> identifier -> identifier -> 'a1) -> (identifier -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> 'a1) -> pseudo_instruction -> 'a1 + +val pseudo_instruction_inv_rect_Type4 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 + +val pseudo_instruction_inv_rect_Type3 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 + +val pseudo_instruction_inv_rect_Type2 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 + +val pseudo_instruction_inv_rect_Type1 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 + +val pseudo_instruction_inv_rect_Type0 : + pseudo_instruction -> (identifier preinstruction -> __ -> 'a1) -> + (String.string -> __ -> 'a1) -> (CostLabel.costlabel -> __ -> 'a1) -> + (identifier -> __ -> 'a1) -> (subaddressing_mode -> identifier -> + identifier -> __ -> 'a1) -> (identifier -> __ -> 'a1) -> + ((subaddressing_mode, (subaddressing_mode, word_side) Types.prod) Types.sum + -> identifier -> BitVector.word -> __ -> 'a1) -> 'a1 + +val pseudo_instruction_discr : pseudo_instruction -> pseudo_instruction -> __ + +val pseudo_instruction_jmdiscr : + pseudo_instruction -> pseudo_instruction -> __ + +type labelled_instruction = pseudo_instruction LabelledObjects.labelled_obj + +type assembly_program = instruction List.list + +val fetch_pseudo_instruction : + labelled_instruction List.list -> BitVector.word -> (pseudo_instruction, + BitVector.word) Types.prod + +val is_jump' : identifier preinstruction -> Bool.bool + +val is_relative_jump : pseudo_instruction -> Bool.bool + +val is_jump : pseudo_instruction -> Bool.bool + +val is_call : pseudo_instruction -> Bool.bool + +val asm_cost_label : + labelled_instruction List.list -> BitVector.word Types.sig0 -> + CostLabel.costlabel Types.option + +val aDDRESS_WIDTH : Nat.nat + +val mAX_CODE_SIZE : Nat.nat + +val code_size_opt : labelled_instruction List.list -> __ Types.option + +type pseudo_assembly_program = { preamble : (identifier, BitVector.word) + Types.prod List.list; + code : labelled_instruction List.list; + renamed_symbols : (identifier, AST.ident) + Types.prod List.list; + final_label : identifier } + +val pseudo_assembly_program_rect_Type4 : + ((identifier, BitVector.word) Types.prod List.list -> labelled_instruction + List.list -> __ -> (identifier, AST.ident) Types.prod List.list -> + identifier -> __ -> __ -> 'a1) -> pseudo_assembly_program -> 'a1 + +val pseudo_assembly_program_rect_Type5 : + ((identifier, BitVector.word) Types.prod List.list -> labelled_instruction + List.list -> __ -> (identifier, AST.ident) Types.prod List.list -> + identifier -> __ -> __ -> 'a1) -> pseudo_assembly_program -> 'a1 + +val pseudo_assembly_program_rect_Type3 : + ((identifier, BitVector.word) Types.prod List.list -> labelled_instruction + List.list -> __ -> (identifier, AST.ident) Types.prod List.list -> + identifier -> __ -> __ -> 'a1) -> pseudo_assembly_program -> 'a1 + +val pseudo_assembly_program_rect_Type2 : + ((identifier, BitVector.word) Types.prod List.list -> labelled_instruction + List.list -> __ -> (identifier, AST.ident) Types.prod List.list -> + identifier -> __ -> __ -> 'a1) -> pseudo_assembly_program -> 'a1 + +val pseudo_assembly_program_rect_Type1 : + ((identifier, BitVector.word) Types.prod List.list -> labelled_instruction + List.list -> __ -> (identifier, AST.ident) Types.prod List.list -> + identifier -> __ -> __ -> 'a1) -> pseudo_assembly_program -> 'a1 + +val pseudo_assembly_program_rect_Type0 : + ((identifier, BitVector.word) Types.prod List.list -> labelled_instruction + List.list -> __ -> (identifier, AST.ident) Types.prod List.list -> + identifier -> __ -> __ -> 'a1) -> pseudo_assembly_program -> 'a1 + +val preamble : + pseudo_assembly_program -> (identifier, BitVector.word) Types.prod + List.list + +val code : pseudo_assembly_program -> labelled_instruction List.list + +val renamed_symbols : + pseudo_assembly_program -> (identifier, AST.ident) Types.prod List.list + +val final_label : pseudo_assembly_program -> identifier + +val pseudo_assembly_program_inv_rect_Type4 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) -> + 'a1 + +val pseudo_assembly_program_inv_rect_Type3 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) -> + 'a1 + +val pseudo_assembly_program_inv_rect_Type2 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) -> + 'a1 + +val pseudo_assembly_program_inv_rect_Type1 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) -> + 'a1 + +val pseudo_assembly_program_inv_rect_Type0 : + pseudo_assembly_program -> ((identifier, BitVector.word) Types.prod + List.list -> labelled_instruction List.list -> __ -> (identifier, + AST.ident) Types.prod List.list -> identifier -> __ -> __ -> __ -> 'a1) -> + 'a1 + +val pseudo_assembly_program_jmdiscr : + pseudo_assembly_program -> pseudo_assembly_program -> __ + +type object_code = BitVector.byte List.list + +val next : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + (BitVector.word, BitVector.byte) Types.prod + +val load_code_memory0 : + object_code -> BitVector.byte BitVectorTrie.bitVectorTrie Types.sig0 + +val load_code_memory : + object_code -> BitVector.byte BitVectorTrie.bitVectorTrie + +type costlabel_map = CostLabel.costlabel BitVectorTrie.bitVectorTrie + +type symboltable_type = AST.ident BitVectorTrie.bitVectorTrie + +type labelled_object_code = { oc : object_code; + cm : BitVector.byte BitVectorTrie.bitVectorTrie; + costlabels : costlabel_map; + symboltable : symboltable_type; + final_pc : BitVector.word } + +val labelled_object_code_rect_Type4 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 + +val labelled_object_code_rect_Type5 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 + +val labelled_object_code_rect_Type3 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 + +val labelled_object_code_rect_Type2 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 + +val labelled_object_code_rect_Type1 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 + +val labelled_object_code_rect_Type0 : + (object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> __ -> + costlabel_map -> symboltable_type -> BitVector.word -> __ -> 'a1) -> + labelled_object_code -> 'a1 + +val oc : labelled_object_code -> object_code + +val cm : labelled_object_code -> BitVector.byte BitVectorTrie.bitVectorTrie + +val costlabels : labelled_object_code -> costlabel_map + +val symboltable : labelled_object_code -> symboltable_type + +val final_pc : labelled_object_code -> BitVector.word + +val labelled_object_code_inv_rect_Type4 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 + +val labelled_object_code_inv_rect_Type3 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 + +val labelled_object_code_inv_rect_Type2 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 + +val labelled_object_code_inv_rect_Type1 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 + +val labelled_object_code_inv_rect_Type0 : + labelled_object_code -> (object_code -> BitVector.byte + BitVectorTrie.bitVectorTrie -> __ -> costlabel_map -> symboltable_type -> + BitVector.word -> __ -> __ -> 'a1) -> 'a1 + +val labelled_object_code_jmdiscr : + labelled_object_code -> labelled_object_code -> __ + diff --git a/extracted/aSMCosts.ml b/extracted/aSMCosts.ml new file mode 100644 index 0000000..41ba9f9 --- /dev/null +++ b/extracted/aSMCosts.ml @@ -0,0 +1,763 @@ +open Preamble + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Interpret + +(** val aSMRegisterRets : ASM.subaddressing_mode List.list **) +let aSMRegisterRets = + List.Cons ((ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))), + (List.Cons ((ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))), + (List.Cons ((ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.False, Vector.VEmpty))))))), (List.Cons ((ASM.REGISTER + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty))))))), List.Nil))))))) + +(** val as_result_of_finaladdr : + 'a1 -> 'a1 Status.preStatus -> BitVector.word -> Integers.int + Types.option **) +let as_result_of_finaladdr cm st finaladdr = + match BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) st.Status.program_counter finaladdr with + | Bool.True -> + let vals = + List.map (fun h -> + Status.get_arg_8 cm st Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_a, (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Registr, Vector.VEmpty)))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + h)) aSMRegisterRets + in + let dummy = + BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) + in + let first_byte = fun l -> + match l with + | List.Nil -> { Types.fst = dummy; Types.snd = List.Nil } + | List.Cons (hd, tl) -> { Types.fst = hd; Types.snd = tl } + in + let { Types.fst = b1; Types.snd = tl1 } = first_byte vals in + let { Types.fst = b2; Types.snd = tl2 } = first_byte tl1 in + let { Types.fst = b3; Types.snd = tl3 } = first_byte tl2 in + let { Types.fst = b4; Types.snd = tl4 } = first_byte tl3 in + Types.Some + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))) b4 + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) b3 + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) b2 b1))) + | Bool.False -> Types.None + +(** val oC_as_call_ident : + ASM.labelled_object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> + Status.status Types.sig0 -> AST.ident **) +let oC_as_call_ident prog cm s0 = + let pc = + (Types.pi1 (Interpret.execute_1' cm (Types.pi1 s0))).Status.program_counter + in + (match BitVectorTrie.lookup_opt (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) pc prog.ASM.symboltable with + | Types.None -> assert false (* absurd case *) + | Types.Some id -> id) + +(** val oC_abstract_status : + ASM.labelled_object_code -> StructuredTraces.abstract_status **) +let oC_abstract_status prog = + { StructuredTraces.as_pc = AbstractStatus.word_deqset; + StructuredTraces.as_pc_of = + (Obj.magic (Status.program_counter prog.ASM.cm)); + StructuredTraces.as_classify = + (Obj.magic (AbstractStatus.oC_classify prog.ASM.cm)); + StructuredTraces.as_label_of_pc = (fun pc -> + BitVectorTrie.lookup_opt (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Obj.magic pc) prog.ASM.costlabels); + StructuredTraces.as_result = (fun st -> + as_result_of_finaladdr prog.ASM.cm (Obj.magic st) prog.ASM.final_pc); + StructuredTraces.as_call_ident = + (Obj.magic (oC_as_call_ident prog prog.ASM.cm)); + StructuredTraces.as_tailcall_ident = (fun clearme -> + let st = clearme in + (match AbstractStatus.current_instruction prog.ASM.cm (Obj.magic st) with + | ASM.ACALL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_call StructuredTraces.Cl_tailcall __) + | ASM.LCALL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_call StructuredTraces.Cl_tailcall __) + | ASM.AJMP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.LJMP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.SJMP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.MOVC (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RealInstruction clearme0 -> + (match clearme0 with + | ASM.ADD (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.ADDC (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.SUBB (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.INC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.DEC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.MUL (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.DIV (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.DA x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.JC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JNC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JB (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JNB (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JBC (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JZ x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JNZ x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.CJNE (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.DJNZ (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.ANL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.ORL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.XRL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.CLR x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.CPL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RLC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RR x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RRC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.SWAP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.MOV x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.MOVX x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.SETB x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.PUSH x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.POP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.XCH (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.XCHD (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RET -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_return StructuredTraces.Cl_tailcall __) + | ASM.RETI -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_return StructuredTraces.Cl_tailcall __) + | ASM.NOP -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.JMP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_call StructuredTraces.Cl_tailcall __))) __) } + +(** val trace_any_label_length : + ASM.labelled_object_code -> StructuredTraces.trace_ends_with_ret -> + Status.status -> Status.status -> StructuredTraces.trace_any_label -> + Nat.nat **) +let trace_any_label_length prog trace_ends_flag start_status final_status the_trace = + StructuredTraces.as_trace_any_label_length' (oC_abstract_status prog) + trace_ends_flag (Obj.magic start_status) (Obj.magic final_status) + the_trace + +(** val all_program_counter_list : + Nat.nat -> BitVector.bitVector List.list **) +let rec all_program_counter_list = function +| Nat.O -> List.Nil +| Nat.S n' -> + List.Cons + ((Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) n'), (all_program_counter_list n')) + +(** val compute_paid_trace_any_label : + ASM.labelled_object_code -> StructuredTraces.trace_ends_with_ret -> + Status.status -> Status.status -> StructuredTraces.trace_any_label -> + Nat.nat **) +let rec compute_paid_trace_any_label prog trace_ends_flag start_status final_status = function +| StructuredTraces.Tal_base_not_return (the_status, x) -> + Interpret.current_instruction_cost prog.ASM.cm (Obj.magic the_status) +| StructuredTraces.Tal_base_return (the_status, x) -> + Interpret.current_instruction_cost prog.ASM.cm (Obj.magic the_status) +| StructuredTraces.Tal_base_call (pre_fun_call, start_fun_call, final, x2) -> + Interpret.current_instruction_cost prog.ASM.cm (Obj.magic pre_fun_call) +| StructuredTraces.Tal_base_tailcall + (pre_fun_call, start_fun_call, final, x1) -> + Interpret.current_instruction_cost prog.ASM.cm (Obj.magic pre_fun_call) +| StructuredTraces.Tal_step_call + (end_flag, pre_fun_call, start_fun_call, after_fun_call, final, + call_trace, final_trace) -> + let current_instruction_cost = + Interpret.current_instruction_cost prog.ASM.cm (Obj.magic pre_fun_call) + in + let final_trace_cost = + compute_paid_trace_any_label prog end_flag (Obj.magic after_fun_call) + (Obj.magic final) final_trace + in + Nat.plus current_instruction_cost final_trace_cost +| StructuredTraces.Tal_step_default + (end_flag, status_pre, status_init, status_end, tail_trace) -> + let current_instruction_cost = + Interpret.current_instruction_cost prog.ASM.cm (Obj.magic status_pre) + in + let tail_trace_cost = + compute_paid_trace_any_label prog end_flag (Obj.magic status_init) + (Obj.magic status_end) tail_trace + in + Nat.plus current_instruction_cost tail_trace_cost + +(** val compute_paid_trace_label_label : + ASM.labelled_object_code -> StructuredTraces.trace_ends_with_ret -> + Status.status -> Status.status -> StructuredTraces.trace_label_label -> + Nat.nat **) +let compute_paid_trace_label_label prog trace_ends_flag start_status final_status = function +| StructuredTraces.Tll_base (ends_flag, initial, final, given_trace) -> + compute_paid_trace_any_label prog ends_flag (Obj.magic initial) + (Obj.magic final) given_trace + +(** val block_cost' : + ASM.labelled_object_code -> BitVector.word -> Nat.nat -> Bool.bool -> + Nat.nat Types.sig0 **) +let rec block_cost' prog program_counter' program_size first_time_around = + (match program_size with + | Nat.O -> (fun _ -> Nat.O) + | Nat.S program_size' -> + (fun _ -> + (let { Types.fst = eta31588; Types.snd = ticks } = + Fetch.fetch prog.ASM.cm program_counter' + in + let { Types.fst = instruction; Types.snd = program_counter'' } = + eta31588 + in + (fun _ -> + let to_continue = + match BitVectorTrie.lookup_opt (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) program_counter' + prog.ASM.costlabels with + | Types.None -> Bool.True + | Types.Some x -> first_time_around + in + let x = + (match to_continue with + | Bool.True -> + (fun _ -> + Types.pi1 + ((match instruction with + | ASM.ACALL addr -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' program_size' + Bool.False))) + | ASM.LCALL addr -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' program_size' + Bool.False))) + | ASM.AJMP addr -> + (fun _ -> + let jump_target = + Interpret.compute_target_of_unconditional_jump + program_counter'' instruction + in + Nat.plus ticks + (Types.pi1 + (block_cost' prog jump_target program_size' + Bool.False))) + | ASM.LJMP addr -> + (fun _ -> + let jump_target = + Interpret.compute_target_of_unconditional_jump + program_counter'' instruction + in + Nat.plus ticks + (Types.pi1 + (block_cost' prog jump_target program_size' + Bool.False))) + | ASM.SJMP addr -> + (fun _ -> + let jump_target = + Interpret.compute_target_of_unconditional_jump + program_counter'' instruction + in + Nat.plus ticks + (Types.pi1 + (block_cost' prog jump_target program_size' + Bool.False))) + | ASM.MOVC (src, trgt) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' program_size' + Bool.False))) + | ASM.RealInstruction real_instruction -> + (fun _ -> + (match real_instruction with + | ASM.ADD (x, x0) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.ADDC (x, x0) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.SUBB (x, x0) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.INC x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.DEC x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.MUL (x, x0) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.DIV (x, x0) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.DA x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.JC relative -> (fun _ -> ticks) + | ASM.JNC relative -> (fun _ -> ticks) + | ASM.JB (bit_addr, relative) -> (fun _ -> ticks) + | ASM.JNB (bit_addr, relative) -> (fun _ -> ticks) + | ASM.JBC (bit_addr, relative) -> (fun _ -> ticks) + | ASM.JZ relative -> (fun _ -> ticks) + | ASM.JNZ relative -> (fun _ -> ticks) + | ASM.CJNE (src_trgt, relative) -> (fun _ -> ticks) + | ASM.DJNZ (src_trgt, relative) -> (fun _ -> ticks) + | ASM.ANL x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.ORL x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.XRL x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.CLR x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.CPL x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.RL x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.RLC x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.RR x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.RRC x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.SWAP x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.MOV x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.MOVX x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.SETB x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.PUSH x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.POP x -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.XCH (x, x0) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.XCHD (x, x0) -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.RET -> (fun _ -> ticks) + | ASM.RETI -> (fun _ -> ticks) + | ASM.NOP -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False))) + | ASM.JMP addr -> + (fun _ -> + Nat.plus ticks + (Types.pi1 + (block_cost' prog program_counter'' + program_size' Bool.False)))) __)) __)) + | Bool.False -> (fun _ -> Nat.O)) __ + in + x)) __)) __ + +(** val block_cost : + ASM.labelled_object_code -> BitVector.word -> Nat.nat Types.sig0 **) +let block_cost prog program_counter = + let cost_of_block = + block_cost' prog program_counter + (Exp.exp (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))) Bool.True + in + cost_of_block + diff --git a/extracted/aSMCosts.mli b/extracted/aSMCosts.mli new file mode 100644 index 0000000..c664ff5 --- /dev/null +++ b/extracted/aSMCosts.mli @@ -0,0 +1,152 @@ +open Preamble + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Interpret + +val aSMRegisterRets : ASM.subaddressing_mode List.list + +val as_result_of_finaladdr : + 'a1 -> 'a1 Status.preStatus -> BitVector.word -> Integers.int Types.option + +val oC_as_call_ident : + ASM.labelled_object_code -> BitVector.byte BitVectorTrie.bitVectorTrie -> + Status.status Types.sig0 -> AST.ident + +val oC_abstract_status : + ASM.labelled_object_code -> StructuredTraces.abstract_status + +val trace_any_label_length : + ASM.labelled_object_code -> StructuredTraces.trace_ends_with_ret -> + Status.status -> Status.status -> StructuredTraces.trace_any_label -> + Nat.nat + +val all_program_counter_list : Nat.nat -> BitVector.bitVector List.list + +val compute_paid_trace_any_label : + ASM.labelled_object_code -> StructuredTraces.trace_ends_with_ret -> + Status.status -> Status.status -> StructuredTraces.trace_any_label -> + Nat.nat + +val compute_paid_trace_label_label : + ASM.labelled_object_code -> StructuredTraces.trace_ends_with_ret -> + Status.status -> Status.status -> StructuredTraces.trace_label_label -> + Nat.nat + +val block_cost' : + ASM.labelled_object_code -> BitVector.word -> Nat.nat -> Bool.bool -> + Nat.nat Types.sig0 + +val block_cost : + ASM.labelled_object_code -> BitVector.word -> Nat.nat Types.sig0 + diff --git a/extracted/aSMCostsSplit.ml b/extracted/aSMCostsSplit.ml new file mode 100644 index 0000000..42fc25a --- /dev/null +++ b/extracted/aSMCostsSplit.ml @@ -0,0 +1,177 @@ +open Preamble + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Interpret + +open ASMCosts + +open UtilBranch + +(** val traverse_code_internal : + ASM.labelled_object_code -> BitVector.word -> Nat.nat -> Nat.nat + Identifiers.identifier_map Types.sig0 **) +let rec traverse_code_internal prog program_counter program_size = + (match program_size with + | Nat.O -> (fun _ -> Identifiers.empty_map PreIdentifiers.CostTag) + | Nat.S program_size' -> + (fun _ -> + let new_program_counter' = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O)) + program_counter + in + let cost_mapping = + traverse_code_internal prog new_program_counter' program_size' + in + (match BitVectorTrie.lookup_opt (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) program_counter + prog.ASM.costlabels with + | Types.None -> (fun _ -> Types.pi1 cost_mapping) + | Types.Some lbl -> + (fun _ -> + let cost = ASMCosts.block_cost prog program_counter in + Identifiers.add PreIdentifiers.CostTag (Types.pi1 cost_mapping) + lbl (Types.pi1 cost))) __)) __ + +(** val traverse_code : + ASM.labelled_object_code -> Nat.nat Identifiers.identifier_map Types.sig0 **) +let traverse_code prog = + Types.pi1 + (traverse_code_internal prog + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) + (Exp.exp (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))))) + +(** val compute_costs : + ASM.labelled_object_code -> Nat.nat Identifiers.identifier_map Types.sig0 **) +let compute_costs = + traverse_code + +(** val aSM_cost_map : + ASM.labelled_object_code -> StructuredTraces.as_cost_map **) +let aSM_cost_map p = + let cost_map = compute_costs p in + (fun l_sig -> + Identifiers.lookup_present PreIdentifiers.CostTag (Types.pi1 cost_map) + (StructuredTraces.as_cost_get_label (ASMCosts.oC_abstract_status p) + l_sig)) + diff --git a/extracted/aSMCostsSplit.mli b/extracted/aSMCostsSplit.mli new file mode 100644 index 0000000..6bd3c53 --- /dev/null +++ b/extracted/aSMCostsSplit.mli @@ -0,0 +1,132 @@ +open Preamble + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Interpret + +open ASMCosts + +open UtilBranch + +val traverse_code_internal : + ASM.labelled_object_code -> BitVector.word -> Nat.nat -> Nat.nat + Identifiers.identifier_map Types.sig0 + +val traverse_code : + ASM.labelled_object_code -> Nat.nat Identifiers.identifier_map Types.sig0 + +val compute_costs : + ASM.labelled_object_code -> Nat.nat Identifiers.identifier_map Types.sig0 + +val aSM_cost_map : ASM.labelled_object_code -> StructuredTraces.as_cost_map + diff --git a/extracted/aST.ml b/extracted/aST.ml new file mode 100644 index 0000000..33c7e88 --- /dev/null +++ b/extracted/aST.ml @@ -0,0 +1,1667 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +type ident = PreIdentifiers.identifier + +(** val ident_eq : ident -> ident -> (__, __) Types.sum **) +let ident_eq = + Identifiers.identifier_eq PreIdentifiers.SymbolTag + +(** val ident_of_nat : Nat.nat -> ident **) +let ident_of_nat = + Identifiers.identifier_of_nat PreIdentifiers.SymbolTag + +type region = +| XData +| Code + +(** val region_rect_Type4 : 'a1 -> 'a1 -> region -> 'a1 **) +let rec region_rect_Type4 h_XData h_Code = function +| XData -> h_XData +| Code -> h_Code + +(** val region_rect_Type5 : 'a1 -> 'a1 -> region -> 'a1 **) +let rec region_rect_Type5 h_XData h_Code = function +| XData -> h_XData +| Code -> h_Code + +(** val region_rect_Type3 : 'a1 -> 'a1 -> region -> 'a1 **) +let rec region_rect_Type3 h_XData h_Code = function +| XData -> h_XData +| Code -> h_Code + +(** val region_rect_Type2 : 'a1 -> 'a1 -> region -> 'a1 **) +let rec region_rect_Type2 h_XData h_Code = function +| XData -> h_XData +| Code -> h_Code + +(** val region_rect_Type1 : 'a1 -> 'a1 -> region -> 'a1 **) +let rec region_rect_Type1 h_XData h_Code = function +| XData -> h_XData +| Code -> h_Code + +(** val region_rect_Type0 : 'a1 -> 'a1 -> region -> 'a1 **) +let rec region_rect_Type0 h_XData h_Code = function +| XData -> h_XData +| Code -> h_Code + +(** val region_inv_rect_Type4 : + region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let region_inv_rect_Type4 hterm h1 h2 = + let hcut = region_rect_Type4 h1 h2 hterm in hcut __ + +(** val region_inv_rect_Type3 : + region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let region_inv_rect_Type3 hterm h1 h2 = + let hcut = region_rect_Type3 h1 h2 hterm in hcut __ + +(** val region_inv_rect_Type2 : + region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let region_inv_rect_Type2 hterm h1 h2 = + let hcut = region_rect_Type2 h1 h2 hterm in hcut __ + +(** val region_inv_rect_Type1 : + region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let region_inv_rect_Type1 hterm h1 h2 = + let hcut = region_rect_Type1 h1 h2 hterm in hcut __ + +(** val region_inv_rect_Type0 : + region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let region_inv_rect_Type0 hterm h1 h2 = + let hcut = region_rect_Type0 h1 h2 hterm in hcut __ + +(** val region_discr : region -> region -> __ **) +let region_discr x y = + Logic.eq_rect_Type2 x + (match x with + | XData -> Obj.magic (fun _ dH -> dH) + | Code -> Obj.magic (fun _ dH -> dH)) y + +(** val region_jmdiscr : region -> region -> __ **) +let region_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | XData -> Obj.magic (fun _ dH -> dH) + | Code -> Obj.magic (fun _ dH -> dH)) y + +(** val eq_region : region -> region -> Bool.bool **) +let eq_region r1 r2 = + match r1 with + | XData -> + (match r2 with + | XData -> Bool.True + | Code -> Bool.False) + | Code -> + (match r2 with + | XData -> Bool.False + | Code -> Bool.True) + +(** val eq_region_elim : + region -> region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let eq_region_elim r1 r2 = + match r1 with + | XData -> + (match r2 with + | XData -> (fun ptrue pfalse -> ptrue __) + | Code -> (fun ptrue pfalse -> pfalse __)) + | Code -> + (match r2 with + | XData -> (fun ptrue pfalse -> pfalse __) + | Code -> (fun ptrue pfalse -> ptrue __)) + +(** val eq_region_dec : region -> region -> (__, __) Types.sum **) +let eq_region_dec r1 r2 = + eq_region_elim r1 r2 (fun _ -> Types.Inl __) (fun _ -> Types.Inr __) + +(** val size_pointer : Nat.nat **) +let size_pointer = + Nat.S (Nat.S Nat.O) + +type signedness = +| Signed +| Unsigned + +(** val signedness_rect_Type4 : 'a1 -> 'a1 -> signedness -> 'a1 **) +let rec signedness_rect_Type4 h_Signed h_Unsigned = function +| Signed -> h_Signed +| Unsigned -> h_Unsigned + +(** val signedness_rect_Type5 : 'a1 -> 'a1 -> signedness -> 'a1 **) +let rec signedness_rect_Type5 h_Signed h_Unsigned = function +| Signed -> h_Signed +| Unsigned -> h_Unsigned + +(** val signedness_rect_Type3 : 'a1 -> 'a1 -> signedness -> 'a1 **) +let rec signedness_rect_Type3 h_Signed h_Unsigned = function +| Signed -> h_Signed +| Unsigned -> h_Unsigned + +(** val signedness_rect_Type2 : 'a1 -> 'a1 -> signedness -> 'a1 **) +let rec signedness_rect_Type2 h_Signed h_Unsigned = function +| Signed -> h_Signed +| Unsigned -> h_Unsigned + +(** val signedness_rect_Type1 : 'a1 -> 'a1 -> signedness -> 'a1 **) +let rec signedness_rect_Type1 h_Signed h_Unsigned = function +| Signed -> h_Signed +| Unsigned -> h_Unsigned + +(** val signedness_rect_Type0 : 'a1 -> 'a1 -> signedness -> 'a1 **) +let rec signedness_rect_Type0 h_Signed h_Unsigned = function +| Signed -> h_Signed +| Unsigned -> h_Unsigned + +(** val signedness_inv_rect_Type4 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let signedness_inv_rect_Type4 hterm h1 h2 = + let hcut = signedness_rect_Type4 h1 h2 hterm in hcut __ + +(** val signedness_inv_rect_Type3 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let signedness_inv_rect_Type3 hterm h1 h2 = + let hcut = signedness_rect_Type3 h1 h2 hterm in hcut __ + +(** val signedness_inv_rect_Type2 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let signedness_inv_rect_Type2 hterm h1 h2 = + let hcut = signedness_rect_Type2 h1 h2 hterm in hcut __ + +(** val signedness_inv_rect_Type1 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let signedness_inv_rect_Type1 hterm h1 h2 = + let hcut = signedness_rect_Type1 h1 h2 hterm in hcut __ + +(** val signedness_inv_rect_Type0 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let signedness_inv_rect_Type0 hterm h1 h2 = + let hcut = signedness_rect_Type0 h1 h2 hterm in hcut __ + +(** val signedness_discr : signedness -> signedness -> __ **) +let signedness_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Signed -> Obj.magic (fun _ dH -> dH) + | Unsigned -> Obj.magic (fun _ dH -> dH)) y + +(** val signedness_jmdiscr : signedness -> signedness -> __ **) +let signedness_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Signed -> Obj.magic (fun _ dH -> dH) + | Unsigned -> Obj.magic (fun _ dH -> dH)) y + +type intsize = +| I8 +| I16 +| I32 + +(** val intsize_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 **) +let rec intsize_rect_Type4 h_I8 h_I16 h_I32 = function +| I8 -> h_I8 +| I16 -> h_I16 +| I32 -> h_I32 + +(** val intsize_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 **) +let rec intsize_rect_Type5 h_I8 h_I16 h_I32 = function +| I8 -> h_I8 +| I16 -> h_I16 +| I32 -> h_I32 + +(** val intsize_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 **) +let rec intsize_rect_Type3 h_I8 h_I16 h_I32 = function +| I8 -> h_I8 +| I16 -> h_I16 +| I32 -> h_I32 + +(** val intsize_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 **) +let rec intsize_rect_Type2 h_I8 h_I16 h_I32 = function +| I8 -> h_I8 +| I16 -> h_I16 +| I32 -> h_I32 + +(** val intsize_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 **) +let rec intsize_rect_Type1 h_I8 h_I16 h_I32 = function +| I8 -> h_I8 +| I16 -> h_I16 +| I32 -> h_I32 + +(** val intsize_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 **) +let rec intsize_rect_Type0 h_I8 h_I16 h_I32 = function +| I8 -> h_I8 +| I16 -> h_I16 +| I32 -> h_I32 + +(** val intsize_inv_rect_Type4 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let intsize_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = intsize_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val intsize_inv_rect_Type3 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let intsize_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = intsize_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val intsize_inv_rect_Type2 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let intsize_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = intsize_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val intsize_inv_rect_Type1 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let intsize_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = intsize_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val intsize_inv_rect_Type0 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let intsize_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = intsize_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val intsize_discr : intsize -> intsize -> __ **) +let intsize_discr x y = + Logic.eq_rect_Type2 x + (match x with + | I8 -> Obj.magic (fun _ dH -> dH) + | I16 -> Obj.magic (fun _ dH -> dH) + | I32 -> Obj.magic (fun _ dH -> dH)) y + +(** val intsize_jmdiscr : intsize -> intsize -> __ **) +let intsize_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | I8 -> Obj.magic (fun _ dH -> dH) + | I16 -> Obj.magic (fun _ dH -> dH) + | I32 -> Obj.magic (fun _ dH -> dH)) y + +type floatsize = +| F32 +| F64 + +(** val floatsize_rect_Type4 : 'a1 -> 'a1 -> floatsize -> 'a1 **) +let rec floatsize_rect_Type4 h_F32 h_F64 = function +| F32 -> h_F32 +| F64 -> h_F64 + +(** val floatsize_rect_Type5 : 'a1 -> 'a1 -> floatsize -> 'a1 **) +let rec floatsize_rect_Type5 h_F32 h_F64 = function +| F32 -> h_F32 +| F64 -> h_F64 + +(** val floatsize_rect_Type3 : 'a1 -> 'a1 -> floatsize -> 'a1 **) +let rec floatsize_rect_Type3 h_F32 h_F64 = function +| F32 -> h_F32 +| F64 -> h_F64 + +(** val floatsize_rect_Type2 : 'a1 -> 'a1 -> floatsize -> 'a1 **) +let rec floatsize_rect_Type2 h_F32 h_F64 = function +| F32 -> h_F32 +| F64 -> h_F64 + +(** val floatsize_rect_Type1 : 'a1 -> 'a1 -> floatsize -> 'a1 **) +let rec floatsize_rect_Type1 h_F32 h_F64 = function +| F32 -> h_F32 +| F64 -> h_F64 + +(** val floatsize_rect_Type0 : 'a1 -> 'a1 -> floatsize -> 'a1 **) +let rec floatsize_rect_Type0 h_F32 h_F64 = function +| F32 -> h_F32 +| F64 -> h_F64 + +(** val floatsize_inv_rect_Type4 : + floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let floatsize_inv_rect_Type4 hterm h1 h2 = + let hcut = floatsize_rect_Type4 h1 h2 hterm in hcut __ + +(** val floatsize_inv_rect_Type3 : + floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let floatsize_inv_rect_Type3 hterm h1 h2 = + let hcut = floatsize_rect_Type3 h1 h2 hterm in hcut __ + +(** val floatsize_inv_rect_Type2 : + floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let floatsize_inv_rect_Type2 hterm h1 h2 = + let hcut = floatsize_rect_Type2 h1 h2 hterm in hcut __ + +(** val floatsize_inv_rect_Type1 : + floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let floatsize_inv_rect_Type1 hterm h1 h2 = + let hcut = floatsize_rect_Type1 h1 h2 hterm in hcut __ + +(** val floatsize_inv_rect_Type0 : + floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let floatsize_inv_rect_Type0 hterm h1 h2 = + let hcut = floatsize_rect_Type0 h1 h2 hterm in hcut __ + +(** val floatsize_discr : floatsize -> floatsize -> __ **) +let floatsize_discr x y = + Logic.eq_rect_Type2 x + (match x with + | F32 -> Obj.magic (fun _ dH -> dH) + | F64 -> Obj.magic (fun _ dH -> dH)) y + +(** val floatsize_jmdiscr : floatsize -> floatsize -> __ **) +let floatsize_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | F32 -> Obj.magic (fun _ dH -> dH) + | F64 -> Obj.magic (fun _ dH -> dH)) y + +type typ = +| ASTint of intsize * signedness +| ASTptr + +(** val typ_rect_Type4 : + (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 **) +let rec typ_rect_Type4 h_ASTint h_ASTptr = function +| ASTint (x_3662, x_3661) -> h_ASTint x_3662 x_3661 +| ASTptr -> h_ASTptr + +(** val typ_rect_Type5 : + (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 **) +let rec typ_rect_Type5 h_ASTint h_ASTptr = function +| ASTint (x_3667, x_3666) -> h_ASTint x_3667 x_3666 +| ASTptr -> h_ASTptr + +(** val typ_rect_Type3 : + (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 **) +let rec typ_rect_Type3 h_ASTint h_ASTptr = function +| ASTint (x_3672, x_3671) -> h_ASTint x_3672 x_3671 +| ASTptr -> h_ASTptr + +(** val typ_rect_Type2 : + (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 **) +let rec typ_rect_Type2 h_ASTint h_ASTptr = function +| ASTint (x_3677, x_3676) -> h_ASTint x_3677 x_3676 +| ASTptr -> h_ASTptr + +(** val typ_rect_Type1 : + (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 **) +let rec typ_rect_Type1 h_ASTint h_ASTptr = function +| ASTint (x_3682, x_3681) -> h_ASTint x_3682 x_3681 +| ASTptr -> h_ASTptr + +(** val typ_rect_Type0 : + (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 **) +let rec typ_rect_Type0 h_ASTint h_ASTptr = function +| ASTint (x_3687, x_3686) -> h_ASTint x_3687 x_3686 +| ASTptr -> h_ASTptr + +(** val typ_inv_rect_Type4 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let typ_inv_rect_Type4 hterm h1 h2 = + let hcut = typ_rect_Type4 h1 h2 hterm in hcut __ + +(** val typ_inv_rect_Type3 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let typ_inv_rect_Type3 hterm h1 h2 = + let hcut = typ_rect_Type3 h1 h2 hterm in hcut __ + +(** val typ_inv_rect_Type2 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let typ_inv_rect_Type2 hterm h1 h2 = + let hcut = typ_rect_Type2 h1 h2 hterm in hcut __ + +(** val typ_inv_rect_Type1 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let typ_inv_rect_Type1 hterm h1 h2 = + let hcut = typ_rect_Type1 h1 h2 hterm in hcut __ + +(** val typ_inv_rect_Type0 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let typ_inv_rect_Type0 hterm h1 h2 = + let hcut = typ_rect_Type0 h1 h2 hterm in hcut __ + +(** val typ_discr : typ -> typ -> __ **) +let typ_discr x y = + Logic.eq_rect_Type2 x + (match x with + | ASTint (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | ASTptr -> Obj.magic (fun _ dH -> dH)) y + +(** val typ_jmdiscr : typ -> typ -> __ **) +let typ_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | ASTint (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | ASTptr -> Obj.magic (fun _ dH -> dH)) y + +type sigType = typ + +(** val sigType_Int : typ **) +let sigType_Int = + ASTint (I32, Unsigned) + +(** val sigType_Ptr : typ **) +let sigType_Ptr = + ASTptr + +(** val pred_size_intsize : intsize -> Nat.nat **) +let pred_size_intsize = function +| I8 -> Nat.O +| I16 -> Nat.S Nat.O +| I32 -> Nat.S (Nat.S (Nat.S Nat.O)) + +(** val size_intsize : intsize -> Nat.nat **) +let size_intsize sz = + Nat.S (pred_size_intsize sz) + +(** val bitsize_of_intsize : intsize -> Nat.nat **) +let bitsize_of_intsize sz = + Nat.times (size_intsize sz) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + +(** val eq_intsize : intsize -> intsize -> Bool.bool **) +let eq_intsize sz1 sz2 = + match sz1 with + | I8 -> + (match sz2 with + | I8 -> Bool.True + | I16 -> Bool.False + | I32 -> Bool.False) + | I16 -> + (match sz2 with + | I8 -> Bool.False + | I16 -> Bool.True + | I32 -> Bool.False) + | I32 -> + (match sz2 with + | I8 -> Bool.False + | I16 -> Bool.False + | I32 -> Bool.True) + +(** val eq_intsize_elim : + intsize -> intsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let eq_intsize_elim clearme sz2 x x0 = + (match clearme with + | I8 -> + (fun clearme0 -> + match clearme0 with + | I8 -> (fun _ hne heq -> heq __) + | I16 -> (fun _ hne heq -> hne __) + | I32 -> (fun _ hne heq -> hne __)) + | I16 -> + (fun clearme0 -> + match clearme0 with + | I8 -> (fun _ hne heq -> hne __) + | I16 -> (fun _ hne heq -> heq __) + | I32 -> (fun _ hne heq -> hne __)) + | I32 -> + (fun clearme0 -> + match clearme0 with + | I8 -> (fun _ hne heq -> hne __) + | I16 -> (fun _ hne heq -> hne __) + | I32 -> (fun _ hne heq -> heq __))) sz2 __ x x0 + +(** val signedness_check : signedness -> signedness -> 'a1 -> 'a1 -> 'a1 **) +let signedness_check sg1 sg2 = + match sg1 with + | Signed -> + (fun x -> + match sg2 with + | Signed -> (fun d -> x) + | Unsigned -> (fun d -> d)) + | Unsigned -> + (fun x -> + match sg2 with + | Signed -> (fun d -> d) + | Unsigned -> (fun d -> x)) + +(** val inttyp_eq_elim' : + intsize -> intsize -> signedness -> signedness -> 'a1 -> 'a1 -> 'a1 **) +let rec inttyp_eq_elim' sz1 sz2 sg1 sg2 = + match sz1 with + | I8 -> + (fun x -> + match sz2 with + | I8 -> signedness_check sg1 sg2 x + | I16 -> (fun d -> d) + | I32 -> (fun d -> d)) + | I16 -> + (fun x -> + match sz2 with + | I8 -> (fun d -> d) + | I16 -> signedness_check sg1 sg2 x + | I32 -> (fun d -> d)) + | I32 -> + (fun x -> + match sz2 with + | I8 -> (fun d -> d) + | I16 -> (fun d -> d) + | I32 -> signedness_check sg1 sg2 x) + +(** val intsize_eq_elim' : intsize -> intsize -> 'a1 -> 'a1 -> 'a1 **) +let rec intsize_eq_elim' sz1 sz2 = + match sz1 with + | I8 -> + (fun x -> + match sz2 with + | I8 -> (fun d -> x) + | I16 -> (fun d -> d) + | I32 -> (fun d -> d)) + | I16 -> + (fun x -> + match sz2 with + | I8 -> (fun d -> d) + | I16 -> (fun d -> x) + | I32 -> (fun d -> d)) + | I32 -> + (fun x -> + match sz2 with + | I8 -> (fun d -> d) + | I16 -> (fun d -> d) + | I32 -> (fun d -> x)) + +(** val intsize_eq_elim : + intsize -> intsize -> 'a2 -> ('a2 -> 'a1) -> 'a1 -> 'a1 **) +let rec intsize_eq_elim sz1 sz2 = + match sz1 with + | I8 -> + (fun x -> + match sz2 with + | I8 -> (fun f d -> f x) + | I16 -> (fun f d -> d) + | I32 -> (fun f d -> d)) + | I16 -> + (fun x -> + match sz2 with + | I8 -> (fun f d -> d) + | I16 -> (fun f d -> f x) + | I32 -> (fun f d -> d)) + | I32 -> + (fun x -> + match sz2 with + | I8 -> (fun f d -> d) + | I16 -> (fun f d -> d) + | I32 -> (fun f d -> f x)) + +(** val intsize_eq_elim_elim : + intsize -> intsize -> 'a2 -> ('a2 -> 'a1) -> 'a1 -> (__ -> 'a3) -> (__ -> + __) -> 'a3 **) +let intsize_eq_elim_elim clearme sz2 p f d x x0 = + (match clearme with + | I8 -> + (fun clearme0 -> + match clearme0 with + | I8 -> (fun _ p0 f0 d0 _ hne heq -> Obj.magic heq __) + | I16 -> (fun _ p0 f0 d0 _ hne heq -> hne __) + | I32 -> (fun _ p0 f0 d0 _ hne heq -> hne __)) + | I16 -> + (fun clearme0 -> + match clearme0 with + | I8 -> (fun _ p0 f0 d0 _ hne heq -> hne __) + | I16 -> (fun _ p0 f0 d0 _ hne heq -> Obj.magic heq __) + | I32 -> (fun _ p0 f0 d0 _ hne heq -> hne __)) + | I32 -> + (fun clearme0 -> + match clearme0 with + | I8 -> (fun _ p0 f0 d0 _ hne heq -> hne __) + | I16 -> (fun _ p0 f0 d0 _ hne heq -> hne __) + | I32 -> (fun _ p0 f0 d0 _ hne heq -> Obj.magic heq __))) sz2 __ p f d + __ x x0 + +type bvint = BitVector.bitVector + +(** val repr : intsize -> Nat.nat -> bvint **) +let repr sz x = + Arithmetic.bitvector_of_nat (bitsize_of_intsize sz) x + +(** val size_floatsize : floatsize -> Nat.nat **) +let size_floatsize sz = + Nat.S + (match sz with + | F32 -> Nat.S (Nat.S (Nat.S Nat.O)) + | F64 -> Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))) + +(** val floatsize_eq_elim : floatsize -> floatsize -> 'a1 -> 'a1 -> 'a1 **) +let rec floatsize_eq_elim sz1 sz2 = + match sz1 with + | F32 -> + (fun x -> + match sz2 with + | F32 -> (fun d -> x) + | F64 -> (fun d -> d)) + | F64 -> + (fun x -> + match sz2 with + | F32 -> (fun d -> d) + | F64 -> (fun d -> x)) + +(** val typesize : typ -> Nat.nat **) +let typesize = function +| ASTint (sz, x) -> size_intsize sz +| ASTptr -> size_pointer + +(** val typ_eq : typ -> typ -> (__, __) Types.sum **) +let typ_eq = function +| ASTint (clearme0, x) -> + (match clearme0 with + | I8 -> + (fun clearme1 -> + match clearme1 with + | Signed -> + (fun clearme2 -> + match clearme2 with + | ASTint (clearme3, x0) -> + (match clearme3 with + | I8 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inl __ + | Unsigned -> Types.Inr __) + | I16 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I32 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __)) x0 + | ASTptr -> Types.Inr __) + | Unsigned -> + (fun clearme2 -> + match clearme2 with + | ASTint (clearme3, x0) -> + (match clearme3 with + | I8 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inl __) + | I16 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I32 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __)) x0 + | ASTptr -> Types.Inr __)) + | I16 -> + (fun clearme1 -> + match clearme1 with + | Signed -> + (fun clearme2 -> + match clearme2 with + | ASTint (clearme3, x0) -> + (match clearme3 with + | I8 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I16 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inl __ + | Unsigned -> Types.Inr __) + | I32 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __)) x0 + | ASTptr -> Types.Inr __) + | Unsigned -> + (fun clearme2 -> + match clearme2 with + | ASTint (clearme3, x0) -> + (match clearme3 with + | I8 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I16 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inl __) + | I32 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __)) x0 + | ASTptr -> Types.Inr __)) + | I32 -> + (fun clearme1 -> + match clearme1 with + | Signed -> + (fun clearme2 -> + match clearme2 with + | ASTint (clearme3, x0) -> + (match clearme3 with + | I8 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I16 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I32 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inl __ + | Unsigned -> Types.Inr __)) x0 + | ASTptr -> Types.Inr __) + | Unsigned -> + (fun clearme2 -> + match clearme2 with + | ASTint (clearme3, x0) -> + (match clearme3 with + | I8 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I16 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I32 -> + (fun clearme4 -> + match clearme4 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inl __)) x0 + | ASTptr -> Types.Inr __))) x +| ASTptr -> + (fun clearme0 -> + match clearme0 with + | ASTint (clearme1, x) -> + (match clearme1 with + | I8 -> + (fun clearme2 -> + match clearme2 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I16 -> + (fun clearme2 -> + match clearme2 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __) + | I32 -> + (fun clearme2 -> + match clearme2 with + | Signed -> Types.Inr __ + | Unsigned -> Types.Inr __)) x + | ASTptr -> Types.Inl __) + +(** val opt_typ_eq : + typ Types.option -> typ Types.option -> (__, __) Types.sum **) +let opt_typ_eq t1 t2 = + match t1 with + | Types.None -> + (match t2 with + | Types.None -> Types.Inl __ + | Types.Some ty -> Types.Inr __) + | Types.Some x -> + (match t2 with + | Types.None -> (fun ty -> Types.Inr __) + | Types.Some ty1 -> + (fun ty2 -> + Types.sum_rect_Type0 (fun _ -> Types.Inl __) (fun _ -> Types.Inr __) + (typ_eq ty1 ty2))) x + +type signature = { sig_args : typ List.list; sig_res : typ Types.option } + +(** val signature_rect_Type4 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 **) +let rec signature_rect_Type4 h_mk_signature x_3722 = + let { sig_args = sig_args0; sig_res = sig_res0 } = x_3722 in + h_mk_signature sig_args0 sig_res0 + +(** val signature_rect_Type5 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 **) +let rec signature_rect_Type5 h_mk_signature x_3724 = + let { sig_args = sig_args0; sig_res = sig_res0 } = x_3724 in + h_mk_signature sig_args0 sig_res0 + +(** val signature_rect_Type3 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 **) +let rec signature_rect_Type3 h_mk_signature x_3726 = + let { sig_args = sig_args0; sig_res = sig_res0 } = x_3726 in + h_mk_signature sig_args0 sig_res0 + +(** val signature_rect_Type2 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 **) +let rec signature_rect_Type2 h_mk_signature x_3728 = + let { sig_args = sig_args0; sig_res = sig_res0 } = x_3728 in + h_mk_signature sig_args0 sig_res0 + +(** val signature_rect_Type1 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 **) +let rec signature_rect_Type1 h_mk_signature x_3730 = + let { sig_args = sig_args0; sig_res = sig_res0 } = x_3730 in + h_mk_signature sig_args0 sig_res0 + +(** val signature_rect_Type0 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 **) +let rec signature_rect_Type0 h_mk_signature x_3732 = + let { sig_args = sig_args0; sig_res = sig_res0 } = x_3732 in + h_mk_signature sig_args0 sig_res0 + +(** val sig_args : signature -> typ List.list **) +let rec sig_args xxx = + xxx.sig_args + +(** val sig_res : signature -> typ Types.option **) +let rec sig_res xxx = + xxx.sig_res + +(** val signature_inv_rect_Type4 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 **) +let signature_inv_rect_Type4 hterm h1 = + let hcut = signature_rect_Type4 h1 hterm in hcut __ + +(** val signature_inv_rect_Type3 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 **) +let signature_inv_rect_Type3 hterm h1 = + let hcut = signature_rect_Type3 h1 hterm in hcut __ + +(** val signature_inv_rect_Type2 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 **) +let signature_inv_rect_Type2 hterm h1 = + let hcut = signature_rect_Type2 h1 hterm in hcut __ + +(** val signature_inv_rect_Type1 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 **) +let signature_inv_rect_Type1 hterm h1 = + let hcut = signature_rect_Type1 h1 hterm in hcut __ + +(** val signature_inv_rect_Type0 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 **) +let signature_inv_rect_Type0 hterm h1 = + let hcut = signature_rect_Type0 h1 hterm in hcut __ + +(** val signature_discr : signature -> signature -> __ **) +let signature_discr x y = + Logic.eq_rect_Type2 x + (let { sig_args = a0; sig_res = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val signature_jmdiscr : signature -> signature -> __ **) +let signature_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { sig_args = a0; sig_res = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +type signature0 = signature + +(** val signature_args : signature -> typ List.list **) +let signature_args = + sig_args + +(** val signature_return : signature -> typ Types.option **) +let signature_return = + sig_res + +(** val proj_sig_res : signature -> typ **) +let proj_sig_res s = + match s.sig_res with + | Types.None -> ASTint (I32, Unsigned) + | Types.Some t -> t + +type init_data = +| Init_int8 of bvint +| Init_int16 of bvint +| Init_int32 of bvint +| Init_space of Nat.nat +| Init_null +| Init_addrof of ident * Nat.nat + +(** val init_data_rect_Type4 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 **) +let rec init_data_rect_Type4 h_Init_int8 h_Init_int16 h_Init_int32 h_Init_space h_Init_null h_Init_addrof = function +| Init_int8 x_3760 -> h_Init_int8 x_3760 +| Init_int16 x_3761 -> h_Init_int16 x_3761 +| Init_int32 x_3762 -> h_Init_int32 x_3762 +| Init_space x_3763 -> h_Init_space x_3763 +| Init_null -> h_Init_null +| Init_addrof (x_3765, x_3764) -> h_Init_addrof x_3765 x_3764 + +(** val init_data_rect_Type5 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 **) +let rec init_data_rect_Type5 h_Init_int8 h_Init_int16 h_Init_int32 h_Init_space h_Init_null h_Init_addrof = function +| Init_int8 x_3773 -> h_Init_int8 x_3773 +| Init_int16 x_3774 -> h_Init_int16 x_3774 +| Init_int32 x_3775 -> h_Init_int32 x_3775 +| Init_space x_3776 -> h_Init_space x_3776 +| Init_null -> h_Init_null +| Init_addrof (x_3778, x_3777) -> h_Init_addrof x_3778 x_3777 + +(** val init_data_rect_Type3 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 **) +let rec init_data_rect_Type3 h_Init_int8 h_Init_int16 h_Init_int32 h_Init_space h_Init_null h_Init_addrof = function +| Init_int8 x_3786 -> h_Init_int8 x_3786 +| Init_int16 x_3787 -> h_Init_int16 x_3787 +| Init_int32 x_3788 -> h_Init_int32 x_3788 +| Init_space x_3789 -> h_Init_space x_3789 +| Init_null -> h_Init_null +| Init_addrof (x_3791, x_3790) -> h_Init_addrof x_3791 x_3790 + +(** val init_data_rect_Type2 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 **) +let rec init_data_rect_Type2 h_Init_int8 h_Init_int16 h_Init_int32 h_Init_space h_Init_null h_Init_addrof = function +| Init_int8 x_3799 -> h_Init_int8 x_3799 +| Init_int16 x_3800 -> h_Init_int16 x_3800 +| Init_int32 x_3801 -> h_Init_int32 x_3801 +| Init_space x_3802 -> h_Init_space x_3802 +| Init_null -> h_Init_null +| Init_addrof (x_3804, x_3803) -> h_Init_addrof x_3804 x_3803 + +(** val init_data_rect_Type1 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 **) +let rec init_data_rect_Type1 h_Init_int8 h_Init_int16 h_Init_int32 h_Init_space h_Init_null h_Init_addrof = function +| Init_int8 x_3812 -> h_Init_int8 x_3812 +| Init_int16 x_3813 -> h_Init_int16 x_3813 +| Init_int32 x_3814 -> h_Init_int32 x_3814 +| Init_space x_3815 -> h_Init_space x_3815 +| Init_null -> h_Init_null +| Init_addrof (x_3817, x_3816) -> h_Init_addrof x_3817 x_3816 + +(** val init_data_rect_Type0 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 **) +let rec init_data_rect_Type0 h_Init_int8 h_Init_int16 h_Init_int32 h_Init_space h_Init_null h_Init_addrof = function +| Init_int8 x_3825 -> h_Init_int8 x_3825 +| Init_int16 x_3826 -> h_Init_int16 x_3826 +| Init_int32 x_3827 -> h_Init_int32 x_3827 +| Init_space x_3828 -> h_Init_space x_3828 +| Init_null -> h_Init_null +| Init_addrof (x_3830, x_3829) -> h_Init_addrof x_3830 x_3829 + +(** val init_data_inv_rect_Type4 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> + __ -> 'a1) -> 'a1 **) +let init_data_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = init_data_rect_Type4 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val init_data_inv_rect_Type3 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> + __ -> 'a1) -> 'a1 **) +let init_data_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 = + let hcut = init_data_rect_Type3 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val init_data_inv_rect_Type2 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> + __ -> 'a1) -> 'a1 **) +let init_data_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 = + let hcut = init_data_rect_Type2 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val init_data_inv_rect_Type1 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> + __ -> 'a1) -> 'a1 **) +let init_data_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 = + let hcut = init_data_rect_Type1 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val init_data_inv_rect_Type0 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> + __ -> 'a1) -> 'a1 **) +let init_data_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 = + let hcut = init_data_rect_Type0 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val init_data_discr : init_data -> init_data -> __ **) +let init_data_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Init_int8 a0 -> Obj.magic (fun _ dH -> dH __) + | Init_int16 a0 -> Obj.magic (fun _ dH -> dH __) + | Init_int32 a0 -> Obj.magic (fun _ dH -> dH __) + | Init_space a0 -> Obj.magic (fun _ dH -> dH __) + | Init_null -> Obj.magic (fun _ dH -> dH) + | Init_addrof (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val init_data_jmdiscr : init_data -> init_data -> __ **) +let init_data_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Init_int8 a0 -> Obj.magic (fun _ dH -> dH __) + | Init_int16 a0 -> Obj.magic (fun _ dH -> dH __) + | Init_int32 a0 -> Obj.magic (fun _ dH -> dH __) + | Init_space a0 -> Obj.magic (fun _ dH -> dH __) + | Init_null -> Obj.magic (fun _ dH -> dH) + | Init_addrof (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +type ('f, 'v) program = { prog_vars : ((ident, region) Types.prod, 'v) + Types.prod List.list; + prog_funct : (ident, 'f) Types.prod List.list; + prog_main : ident } + +(** val program_rect_Type4 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 **) +let rec program_rect_Type4 h_mk_program x_3917 = + let { prog_vars = prog_vars0; prog_funct = prog_funct0; prog_main = + prog_main0 } = x_3917 + in + h_mk_program prog_vars0 prog_funct0 prog_main0 + +(** val program_rect_Type5 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 **) +let rec program_rect_Type5 h_mk_program x_3919 = + let { prog_vars = prog_vars0; prog_funct = prog_funct0; prog_main = + prog_main0 } = x_3919 + in + h_mk_program prog_vars0 prog_funct0 prog_main0 + +(** val program_rect_Type3 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 **) +let rec program_rect_Type3 h_mk_program x_3921 = + let { prog_vars = prog_vars0; prog_funct = prog_funct0; prog_main = + prog_main0 } = x_3921 + in + h_mk_program prog_vars0 prog_funct0 prog_main0 + +(** val program_rect_Type2 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 **) +let rec program_rect_Type2 h_mk_program x_3923 = + let { prog_vars = prog_vars0; prog_funct = prog_funct0; prog_main = + prog_main0 } = x_3923 + in + h_mk_program prog_vars0 prog_funct0 prog_main0 + +(** val program_rect_Type1 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 **) +let rec program_rect_Type1 h_mk_program x_3925 = + let { prog_vars = prog_vars0; prog_funct = prog_funct0; prog_main = + prog_main0 } = x_3925 + in + h_mk_program prog_vars0 prog_funct0 prog_main0 + +(** val program_rect_Type0 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 **) +let rec program_rect_Type0 h_mk_program x_3927 = + let { prog_vars = prog_vars0; prog_funct = prog_funct0; prog_main = + prog_main0 } = x_3927 + in + h_mk_program prog_vars0 prog_funct0 prog_main0 + +(** val prog_vars : + ('a1, 'a2) program -> ((ident, region) Types.prod, 'a2) Types.prod + List.list **) +let rec prog_vars xxx = + xxx.prog_vars + +(** val prog_funct : + ('a1, 'a2) program -> (ident, 'a1) Types.prod List.list **) +let rec prog_funct xxx = + xxx.prog_funct + +(** val prog_main : ('a1, 'a2) program -> ident **) +let rec prog_main xxx = + xxx.prog_main + +(** val program_inv_rect_Type4 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 **) +let program_inv_rect_Type4 hterm h1 = + let hcut = program_rect_Type4 h1 hterm in hcut __ + +(** val program_inv_rect_Type3 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 **) +let program_inv_rect_Type3 hterm h1 = + let hcut = program_rect_Type3 h1 hterm in hcut __ + +(** val program_inv_rect_Type2 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 **) +let program_inv_rect_Type2 hterm h1 = + let hcut = program_rect_Type2 h1 hterm in hcut __ + +(** val program_inv_rect_Type1 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 **) +let program_inv_rect_Type1 hterm h1 = + let hcut = program_rect_Type1 h1 hterm in hcut __ + +(** val program_inv_rect_Type0 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 **) +let program_inv_rect_Type0 hterm h1 = + let hcut = program_rect_Type0 h1 hterm in hcut __ + +(** val program_discr : ('a1, 'a2) program -> ('a1, 'a2) program -> __ **) +let program_discr x y = + Logic.eq_rect_Type2 x + (let { prog_vars = a0; prog_funct = a10; prog_main = a20 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val program_jmdiscr : ('a1, 'a2) program -> ('a1, 'a2) program -> __ **) +let program_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { prog_vars = a0; prog_funct = a10; prog_main = a20 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val prog_funct_names : ('a1, 'a2) program -> ident List.list **) +let prog_funct_names p = + List.map Types.fst p.prog_funct + +(** val prog_var_names : ('a1, 'a2) program -> ident List.list **) +let prog_var_names p = + List.map (fun x -> x.Types.fst.Types.fst) p.prog_vars + +(** val transf_program : + ('a1 -> 'a2) -> (ident, 'a1) Types.prod List.list -> (ident, 'a2) + Types.prod List.list **) +let transf_program transf l = + List.map (fun id_fn -> { Types.fst = id_fn.Types.fst; Types.snd = + (transf id_fn.Types.snd) }) l + +(** val transform_program : + ('a1, 'a3) program -> (ident List.list -> 'a1 -> 'a2) -> ('a2, 'a3) + program **) +let transform_program p transf = + { prog_vars = p.prog_vars; prog_funct = + (transf_program + (transf (List.map (fun x -> x.Types.fst.Types.fst) p.prog_vars)) + p.prog_funct); prog_main = p.prog_main } + +(** val transf_program_gen : + PreIdentifiers.identifierTag -> Identifiers.universe -> + (Identifiers.universe -> 'a1 -> ('a2, Identifiers.universe) Types.prod) + -> (ident, 'a1) Types.prod List.list -> ((ident, 'a2) Types.prod + List.list, Identifiers.universe) Types.prod **) +let transf_program_gen tag gen transf l = + List.foldr (fun id_fn bs_gen -> + let { Types.fst = fn'; Types.snd = gen' } = + transf bs_gen.Types.snd id_fn.Types.snd + in + { Types.fst = (List.Cons ({ Types.fst = id_fn.Types.fst; Types.snd = + fn' }, bs_gen.Types.fst)); Types.snd = gen' }) { Types.fst = List.Nil; + Types.snd = gen } l + +(** val transform_program_gen : + PreIdentifiers.identifierTag -> Identifiers.universe -> ('a1, 'a3) + program -> (ident List.list -> Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> (('a2, 'a3) program, + Identifiers.universe) Types.prod **) +let transform_program_gen tag gen p trans = + let fsg = + transf_program_gen tag gen + (trans (List.map (fun x -> x.Types.fst.Types.fst) p.prog_vars)) + p.prog_funct + in + { Types.fst = { prog_vars = p.prog_vars; prog_funct = fsg.Types.fst; + prog_main = p.prog_main }; Types.snd = fsg.Types.snd } + +(** val map_partial : + ('a2 -> 'a3 Errors.res) -> ('a1, 'a2) Types.prod List.list -> ('a1, 'a3) + Types.prod List.list Errors.res **) +let map_partial f = + Obj.magic + (Monad.m_list_map (Monad.max_def Errors.res0) (fun ab -> + let { Types.fst = a; Types.snd = b } = ab in + Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic f b) (fun c -> + Obj.magic (Errors.OK { Types.fst = a; Types.snd = c })))) + +(** val transform_partial_program : + ('a1, 'a3) program -> (ident List.list -> 'a1 -> 'a2 Errors.res) -> ('a2, + 'a3) program Errors.res **) +let transform_partial_program p transf_partial = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (map_partial + (transf_partial + (List.map (fun x -> x.Types.fst.Types.fst) p.prog_vars)) + p.prog_funct)) (fun fl -> + Obj.magic (Errors.OK { prog_vars = p.prog_vars; prog_funct = fl; + prog_main = p.prog_main }))) + +(** val transform_partial_program2 : + ('a1, 'a3) program -> (ident List.list -> 'a1 -> 'a2 Errors.res) -> ('a3 + -> 'a4 Errors.res) -> ('a2, 'a4) program Errors.res **) +let transform_partial_program2 p transf_partial_function transf_partial_variable = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (map_partial + (transf_partial_function + (List.map (fun x -> x.Types.fst.Types.fst) p.prog_vars)) + p.prog_funct)) (fun fl -> + (match map_partial transf_partial_variable p.prog_vars with + | Errors.OK vl -> + (fun _ -> + Obj.magic (Errors.OK { prog_vars = vl; prog_funct = + (Logic.eq_rect_Type0 + (List.map (fun x -> x.Types.fst.Types.fst) p.prog_vars) fl + (List.map (fun x -> x.Types.fst.Types.fst) vl)); prog_main = + p.prog_main })) + | Errors.Error err -> (fun _ -> Obj.magic (Errors.Error err))) __)) + +type matching = +| Mk_matching + +(** val matching_rect_Type4 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 **) +let rec matching_rect_Type4 h_mk_matching = function +| Mk_matching -> h_mk_matching __ __ __ __ __ __ + +(** val matching_rect_Type5 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 **) +let rec matching_rect_Type5 h_mk_matching = function +| Mk_matching -> h_mk_matching __ __ __ __ __ __ + +(** val matching_rect_Type3 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 **) +let rec matching_rect_Type3 h_mk_matching = function +| Mk_matching -> h_mk_matching __ __ __ __ __ __ + +(** val matching_rect_Type2 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 **) +let rec matching_rect_Type2 h_mk_matching = function +| Mk_matching -> h_mk_matching __ __ __ __ __ __ + +(** val matching_rect_Type1 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 **) +let rec matching_rect_Type1 h_mk_matching = function +| Mk_matching -> h_mk_matching __ __ __ __ __ __ + +(** val matching_rect_Type0 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 **) +let rec matching_rect_Type0 h_mk_matching = function +| Mk_matching -> h_mk_matching __ __ __ __ __ __ + +type m_A = __ + +type m_B = __ + +type m_V = __ + +type m_W = __ + +(** val matching_inv_rect_Type4 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let matching_inv_rect_Type4 hterm h1 = + let hcut = matching_rect_Type4 h1 hterm in hcut __ + +(** val matching_inv_rect_Type3 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let matching_inv_rect_Type3 hterm h1 = + let hcut = matching_rect_Type3 h1 hterm in hcut __ + +(** val matching_inv_rect_Type2 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let matching_inv_rect_Type2 hterm h1 = + let hcut = matching_rect_Type2 h1 hterm in hcut __ + +(** val matching_inv_rect_Type1 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let matching_inv_rect_Type1 hterm h1 = + let hcut = matching_rect_Type1 h1 hterm in hcut __ + +(** val matching_inv_rect_Type0 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let matching_inv_rect_Type0 hterm h1 = + let hcut = matching_rect_Type0 h1 hterm in hcut __ + +(** val matching_jmdiscr : matching -> matching -> __ **) +let matching_jmdiscr x y = + Logic.eq_rect_Type2 x + (let Mk_matching = x in Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val mfe_cast_fn_type : + matching -> ident List.list -> ident List.list -> __ -> __ **) +let mfe_cast_fn_type m vs vs' = + Extralib.eq_rect_Type0_r vs (fun m0 -> m0) vs' + +(** val match_program_rect_Type4 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> + 'a1) -> 'a1 **) +let rec match_program_rect_Type4 m p1 p2 h_mk_match_program = + h_mk_match_program __ __ __ + +(** val match_program_rect_Type5 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> + 'a1) -> 'a1 **) +let rec match_program_rect_Type5 m p1 p2 h_mk_match_program = + h_mk_match_program __ __ __ + +(** val match_program_rect_Type3 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> + 'a1) -> 'a1 **) +let rec match_program_rect_Type3 m p1 p2 h_mk_match_program = + h_mk_match_program __ __ __ + +(** val match_program_rect_Type2 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> + 'a1) -> 'a1 **) +let rec match_program_rect_Type2 m p1 p2 h_mk_match_program = + h_mk_match_program __ __ __ + +(** val match_program_rect_Type1 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> + 'a1) -> 'a1 **) +let rec match_program_rect_Type1 m p1 p2 h_mk_match_program = + h_mk_match_program __ __ __ + +(** val match_program_rect_Type0 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> + 'a1) -> 'a1 **) +let rec match_program_rect_Type0 m p1 p2 h_mk_match_program = + h_mk_match_program __ __ __ + +(** val match_program_inv_rect_Type4 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let match_program_inv_rect_Type4 x1 x2 x3 h1 = + let hcut = match_program_rect_Type4 x1 x2 x3 h1 in hcut __ + +(** val match_program_inv_rect_Type3 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let match_program_inv_rect_Type3 x1 x2 x3 h1 = + let hcut = match_program_rect_Type3 x1 x2 x3 h1 in hcut __ + +(** val match_program_inv_rect_Type2 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let match_program_inv_rect_Type2 x1 x2 x3 h1 = + let hcut = match_program_rect_Type2 x1 x2 x3 h1 in hcut __ + +(** val match_program_inv_rect_Type1 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let match_program_inv_rect_Type1 x1 x2 x3 h1 = + let hcut = match_program_rect_Type1 x1 x2 x3 h1 in hcut __ + +(** val match_program_inv_rect_Type0 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let match_program_inv_rect_Type0 x1 x2 x3 h1 = + let hcut = match_program_rect_Type0 x1 x2 x3 h1 in hcut __ + +(** val match_program_discr : + matching -> (__, __) program -> (__, __) program -> __ **) +let match_program_discr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val match_program_jmdiscr : + matching -> (__, __) program -> (__, __) program -> __ **) +let match_program_jmdiscr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +type external_function = { ef_id : ident; ef_sig : signature } + +(** val external_function_rect_Type4 : + (ident -> signature -> 'a1) -> external_function -> 'a1 **) +let rec external_function_rect_Type4 h_mk_external_function x_4131 = + let { ef_id = ef_id0; ef_sig = ef_sig0 } = x_4131 in + h_mk_external_function ef_id0 ef_sig0 + +(** val external_function_rect_Type5 : + (ident -> signature -> 'a1) -> external_function -> 'a1 **) +let rec external_function_rect_Type5 h_mk_external_function x_4133 = + let { ef_id = ef_id0; ef_sig = ef_sig0 } = x_4133 in + h_mk_external_function ef_id0 ef_sig0 + +(** val external_function_rect_Type3 : + (ident -> signature -> 'a1) -> external_function -> 'a1 **) +let rec external_function_rect_Type3 h_mk_external_function x_4135 = + let { ef_id = ef_id0; ef_sig = ef_sig0 } = x_4135 in + h_mk_external_function ef_id0 ef_sig0 + +(** val external_function_rect_Type2 : + (ident -> signature -> 'a1) -> external_function -> 'a1 **) +let rec external_function_rect_Type2 h_mk_external_function x_4137 = + let { ef_id = ef_id0; ef_sig = ef_sig0 } = x_4137 in + h_mk_external_function ef_id0 ef_sig0 + +(** val external_function_rect_Type1 : + (ident -> signature -> 'a1) -> external_function -> 'a1 **) +let rec external_function_rect_Type1 h_mk_external_function x_4139 = + let { ef_id = ef_id0; ef_sig = ef_sig0 } = x_4139 in + h_mk_external_function ef_id0 ef_sig0 + +(** val external_function_rect_Type0 : + (ident -> signature -> 'a1) -> external_function -> 'a1 **) +let rec external_function_rect_Type0 h_mk_external_function x_4141 = + let { ef_id = ef_id0; ef_sig = ef_sig0 } = x_4141 in + h_mk_external_function ef_id0 ef_sig0 + +(** val ef_id : external_function -> ident **) +let rec ef_id xxx = + xxx.ef_id + +(** val ef_sig : external_function -> signature **) +let rec ef_sig xxx = + xxx.ef_sig + +(** val external_function_inv_rect_Type4 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 **) +let external_function_inv_rect_Type4 hterm h1 = + let hcut = external_function_rect_Type4 h1 hterm in hcut __ + +(** val external_function_inv_rect_Type3 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 **) +let external_function_inv_rect_Type3 hterm h1 = + let hcut = external_function_rect_Type3 h1 hterm in hcut __ + +(** val external_function_inv_rect_Type2 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 **) +let external_function_inv_rect_Type2 hterm h1 = + let hcut = external_function_rect_Type2 h1 hterm in hcut __ + +(** val external_function_inv_rect_Type1 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 **) +let external_function_inv_rect_Type1 hterm h1 = + let hcut = external_function_rect_Type1 h1 hterm in hcut __ + +(** val external_function_inv_rect_Type0 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 **) +let external_function_inv_rect_Type0 hterm h1 = + let hcut = external_function_rect_Type0 h1 hterm in hcut __ + +(** val external_function_discr : + external_function -> external_function -> __ **) +let external_function_discr x y = + Logic.eq_rect_Type2 x + (let { ef_id = a0; ef_sig = a1 } = x in Obj.magic (fun _ dH -> dH __ __)) + y + +(** val external_function_jmdiscr : + external_function -> external_function -> __ **) +let external_function_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { ef_id = a0; ef_sig = a1 } = x in Obj.magic (fun _ dH -> dH __ __)) + y + +type externalFunction = external_function + +(** val external_function_tag : external_function -> ident **) +let external_function_tag = + ef_id + +(** val external_function_sig : external_function -> signature **) +let external_function_sig = + ef_sig + +type 'f fundef = +| Internal of 'f +| External of external_function + +(** val fundef_rect_Type4 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 **) +let rec fundef_rect_Type4 h_Internal h_External = function +| Internal x_4161 -> h_Internal x_4161 +| External x_4162 -> h_External x_4162 + +(** val fundef_rect_Type5 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 **) +let rec fundef_rect_Type5 h_Internal h_External = function +| Internal x_4166 -> h_Internal x_4166 +| External x_4167 -> h_External x_4167 + +(** val fundef_rect_Type3 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 **) +let rec fundef_rect_Type3 h_Internal h_External = function +| Internal x_4171 -> h_Internal x_4171 +| External x_4172 -> h_External x_4172 + +(** val fundef_rect_Type2 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 **) +let rec fundef_rect_Type2 h_Internal h_External = function +| Internal x_4176 -> h_Internal x_4176 +| External x_4177 -> h_External x_4177 + +(** val fundef_rect_Type1 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 **) +let rec fundef_rect_Type1 h_Internal h_External = function +| Internal x_4181 -> h_Internal x_4181 +| External x_4182 -> h_External x_4182 + +(** val fundef_rect_Type0 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 **) +let rec fundef_rect_Type0 h_Internal h_External = function +| Internal x_4186 -> h_Internal x_4186 +| External x_4187 -> h_External x_4187 + +(** val fundef_inv_rect_Type4 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> + 'a2 **) +let fundef_inv_rect_Type4 hterm h1 h2 = + let hcut = fundef_rect_Type4 h1 h2 hterm in hcut __ + +(** val fundef_inv_rect_Type3 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> + 'a2 **) +let fundef_inv_rect_Type3 hterm h1 h2 = + let hcut = fundef_rect_Type3 h1 h2 hterm in hcut __ + +(** val fundef_inv_rect_Type2 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> + 'a2 **) +let fundef_inv_rect_Type2 hterm h1 h2 = + let hcut = fundef_rect_Type2 h1 h2 hterm in hcut __ + +(** val fundef_inv_rect_Type1 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> + 'a2 **) +let fundef_inv_rect_Type1 hterm h1 h2 = + let hcut = fundef_rect_Type1 h1 h2 hterm in hcut __ + +(** val fundef_inv_rect_Type0 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> + 'a2 **) +let fundef_inv_rect_Type0 hterm h1 h2 = + let hcut = fundef_rect_Type0 h1 h2 hterm in hcut __ + +(** val fundef_discr : 'a1 fundef -> 'a1 fundef -> __ **) +let fundef_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Internal a0 -> Obj.magic (fun _ dH -> dH __) + | External a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val fundef_jmdiscr : 'a1 fundef -> 'a1 fundef -> __ **) +let fundef_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Internal a0 -> Obj.magic (fun _ dH -> dH __) + | External a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val transf_fundef : ('a1 -> 'a2) -> 'a1 fundef -> 'a2 fundef **) +let transf_fundef transf = function +| Internal f -> Internal (transf f) +| External ef -> External ef + +(** val transf_partial_fundef : + ('a1 -> 'a2 Errors.res) -> 'a1 fundef -> 'a2 fundef Errors.res **) +let transf_partial_fundef transf_partial = function +| Internal f -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic transf_partial f) + (fun f' -> Obj.magic (Errors.OK (Internal f')))) +| External ef -> Errors.OK (External ef) + diff --git a/extracted/aST.mli b/extracted/aST.mli new file mode 100644 index 0000000..afcf840 --- /dev/null +++ b/extracted/aST.mli @@ -0,0 +1,698 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +type ident = PreIdentifiers.identifier + +val ident_eq : ident -> ident -> (__, __) Types.sum + +val ident_of_nat : Nat.nat -> ident + +type region = +| XData +| Code + +val region_rect_Type4 : 'a1 -> 'a1 -> region -> 'a1 + +val region_rect_Type5 : 'a1 -> 'a1 -> region -> 'a1 + +val region_rect_Type3 : 'a1 -> 'a1 -> region -> 'a1 + +val region_rect_Type2 : 'a1 -> 'a1 -> region -> 'a1 + +val region_rect_Type1 : 'a1 -> 'a1 -> region -> 'a1 + +val region_rect_Type0 : 'a1 -> 'a1 -> region -> 'a1 + +val region_inv_rect_Type4 : region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val region_inv_rect_Type3 : region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val region_inv_rect_Type2 : region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val region_inv_rect_Type1 : region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val region_inv_rect_Type0 : region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val region_discr : region -> region -> __ + +val region_jmdiscr : region -> region -> __ + +val eq_region : region -> region -> Bool.bool + +val eq_region_elim : region -> region -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val eq_region_dec : region -> region -> (__, __) Types.sum + +val size_pointer : Nat.nat + +type signedness = +| Signed +| Unsigned + +val signedness_rect_Type4 : 'a1 -> 'a1 -> signedness -> 'a1 + +val signedness_rect_Type5 : 'a1 -> 'a1 -> signedness -> 'a1 + +val signedness_rect_Type3 : 'a1 -> 'a1 -> signedness -> 'a1 + +val signedness_rect_Type2 : 'a1 -> 'a1 -> signedness -> 'a1 + +val signedness_rect_Type1 : 'a1 -> 'a1 -> signedness -> 'a1 + +val signedness_rect_Type0 : 'a1 -> 'a1 -> signedness -> 'a1 + +val signedness_inv_rect_Type4 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val signedness_inv_rect_Type3 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val signedness_inv_rect_Type2 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val signedness_inv_rect_Type1 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val signedness_inv_rect_Type0 : + signedness -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val signedness_discr : signedness -> signedness -> __ + +val signedness_jmdiscr : signedness -> signedness -> __ + +type intsize = +| I8 +| I16 +| I32 + +val intsize_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 + +val intsize_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 + +val intsize_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 + +val intsize_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 + +val intsize_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 + +val intsize_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> intsize -> 'a1 + +val intsize_inv_rect_Type4 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val intsize_inv_rect_Type3 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val intsize_inv_rect_Type2 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val intsize_inv_rect_Type1 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val intsize_inv_rect_Type0 : + intsize -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val intsize_discr : intsize -> intsize -> __ + +val intsize_jmdiscr : intsize -> intsize -> __ + +type floatsize = +| F32 +| F64 + +val floatsize_rect_Type4 : 'a1 -> 'a1 -> floatsize -> 'a1 + +val floatsize_rect_Type5 : 'a1 -> 'a1 -> floatsize -> 'a1 + +val floatsize_rect_Type3 : 'a1 -> 'a1 -> floatsize -> 'a1 + +val floatsize_rect_Type2 : 'a1 -> 'a1 -> floatsize -> 'a1 + +val floatsize_rect_Type1 : 'a1 -> 'a1 -> floatsize -> 'a1 + +val floatsize_rect_Type0 : 'a1 -> 'a1 -> floatsize -> 'a1 + +val floatsize_inv_rect_Type4 : floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val floatsize_inv_rect_Type3 : floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val floatsize_inv_rect_Type2 : floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val floatsize_inv_rect_Type1 : floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val floatsize_inv_rect_Type0 : floatsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val floatsize_discr : floatsize -> floatsize -> __ + +val floatsize_jmdiscr : floatsize -> floatsize -> __ + +type typ = +| ASTint of intsize * signedness +| ASTptr + +val typ_rect_Type4 : (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 + +val typ_rect_Type5 : (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 + +val typ_rect_Type3 : (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 + +val typ_rect_Type2 : (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 + +val typ_rect_Type1 : (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 + +val typ_rect_Type0 : (intsize -> signedness -> 'a1) -> 'a1 -> typ -> 'a1 + +val typ_inv_rect_Type4 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val typ_inv_rect_Type3 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val typ_inv_rect_Type2 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val typ_inv_rect_Type1 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val typ_inv_rect_Type0 : + typ -> (intsize -> signedness -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val typ_discr : typ -> typ -> __ + +val typ_jmdiscr : typ -> typ -> __ + +type sigType = typ + +val sigType_Int : typ + +val sigType_Ptr : typ + +val pred_size_intsize : intsize -> Nat.nat + +val size_intsize : intsize -> Nat.nat + +val bitsize_of_intsize : intsize -> Nat.nat + +val eq_intsize : intsize -> intsize -> Bool.bool + +val eq_intsize_elim : intsize -> intsize -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val signedness_check : signedness -> signedness -> 'a1 -> 'a1 -> 'a1 + +val inttyp_eq_elim' : + intsize -> intsize -> signedness -> signedness -> 'a1 -> 'a1 -> 'a1 + +val intsize_eq_elim' : intsize -> intsize -> 'a1 -> 'a1 -> 'a1 + +val intsize_eq_elim : intsize -> intsize -> 'a2 -> ('a2 -> 'a1) -> 'a1 -> 'a1 + +val intsize_eq_elim_elim : + intsize -> intsize -> 'a2 -> ('a2 -> 'a1) -> 'a1 -> (__ -> 'a3) -> (__ -> + __) -> 'a3 + +type bvint = BitVector.bitVector + +val repr : intsize -> Nat.nat -> bvint + +val size_floatsize : floatsize -> Nat.nat + +val floatsize_eq_elim : floatsize -> floatsize -> 'a1 -> 'a1 -> 'a1 + +val typesize : typ -> Nat.nat + +val typ_eq : typ -> typ -> (__, __) Types.sum + +val opt_typ_eq : typ Types.option -> typ Types.option -> (__, __) Types.sum + +type signature = { sig_args : typ List.list; sig_res : typ Types.option } + +val signature_rect_Type4 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 + +val signature_rect_Type5 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 + +val signature_rect_Type3 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 + +val signature_rect_Type2 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 + +val signature_rect_Type1 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 + +val signature_rect_Type0 : + (typ List.list -> typ Types.option -> 'a1) -> signature -> 'a1 + +val sig_args : signature -> typ List.list + +val sig_res : signature -> typ Types.option + +val signature_inv_rect_Type4 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 + +val signature_inv_rect_Type3 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 + +val signature_inv_rect_Type2 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 + +val signature_inv_rect_Type1 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 + +val signature_inv_rect_Type0 : + signature -> (typ List.list -> typ Types.option -> __ -> 'a1) -> 'a1 + +val signature_discr : signature -> signature -> __ + +val signature_jmdiscr : signature -> signature -> __ + +type signature0 = signature + +val signature_args : signature -> typ List.list + +val signature_return : signature -> typ Types.option + +val proj_sig_res : signature -> typ + +type init_data = +| Init_int8 of bvint +| Init_int16 of bvint +| Init_int32 of bvint +| Init_space of Nat.nat +| Init_null +| Init_addrof of ident * Nat.nat + +val init_data_rect_Type4 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 + +val init_data_rect_Type5 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 + +val init_data_rect_Type3 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 + +val init_data_rect_Type2 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 + +val init_data_rect_Type1 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 + +val init_data_rect_Type0 : + (bvint -> 'a1) -> (bvint -> 'a1) -> (bvint -> 'a1) -> (Nat.nat -> 'a1) -> + 'a1 -> (ident -> Nat.nat -> 'a1) -> init_data -> 'a1 + +val init_data_inv_rect_Type4 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> __ + -> 'a1) -> 'a1 + +val init_data_inv_rect_Type3 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> __ + -> 'a1) -> 'a1 + +val init_data_inv_rect_Type2 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> __ + -> 'a1) -> 'a1 + +val init_data_inv_rect_Type1 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> __ + -> 'a1) -> 'a1 + +val init_data_inv_rect_Type0 : + init_data -> (bvint -> __ -> 'a1) -> (bvint -> __ -> 'a1) -> (bvint -> __ + -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> 'a1) -> (ident -> Nat.nat -> __ + -> 'a1) -> 'a1 + +val init_data_discr : init_data -> init_data -> __ + +val init_data_jmdiscr : init_data -> init_data -> __ + +type ('f, 'v) program = { prog_vars : ((ident, region) Types.prod, 'v) + Types.prod List.list; + prog_funct : (ident, 'f) Types.prod List.list; + prog_main : ident } + +val program_rect_Type4 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 + +val program_rect_Type5 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 + +val program_rect_Type3 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 + +val program_rect_Type2 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 + +val program_rect_Type1 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 + +val program_rect_Type0 : + (((ident, region) Types.prod, 'a2) Types.prod List.list -> (ident, 'a1) + Types.prod List.list -> ident -> 'a3) -> ('a1, 'a2) program -> 'a3 + +val prog_vars : + ('a1, 'a2) program -> ((ident, region) Types.prod, 'a2) Types.prod + List.list + +val prog_funct : ('a1, 'a2) program -> (ident, 'a1) Types.prod List.list + +val prog_main : ('a1, 'a2) program -> ident + +val program_inv_rect_Type4 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 + +val program_inv_rect_Type3 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 + +val program_inv_rect_Type2 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 + +val program_inv_rect_Type1 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 + +val program_inv_rect_Type0 : + ('a1, 'a2) program -> (((ident, region) Types.prod, 'a2) Types.prod + List.list -> (ident, 'a1) Types.prod List.list -> ident -> __ -> 'a3) -> + 'a3 + +val program_discr : ('a1, 'a2) program -> ('a1, 'a2) program -> __ + +val program_jmdiscr : ('a1, 'a2) program -> ('a1, 'a2) program -> __ + +val prog_funct_names : ('a1, 'a2) program -> ident List.list + +val prog_var_names : ('a1, 'a2) program -> ident List.list + +val transf_program : + ('a1 -> 'a2) -> (ident, 'a1) Types.prod List.list -> (ident, 'a2) + Types.prod List.list + +val transform_program : + ('a1, 'a3) program -> (ident List.list -> 'a1 -> 'a2) -> ('a2, 'a3) program + +val transf_program_gen : + PreIdentifiers.identifierTag -> Identifiers.universe -> + (Identifiers.universe -> 'a1 -> ('a2, Identifiers.universe) Types.prod) -> + (ident, 'a1) Types.prod List.list -> ((ident, 'a2) Types.prod List.list, + Identifiers.universe) Types.prod + +val transform_program_gen : + PreIdentifiers.identifierTag -> Identifiers.universe -> ('a1, 'a3) program + -> (ident List.list -> Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> (('a2, 'a3) program, + Identifiers.universe) Types.prod + +val map_partial : + ('a2 -> 'a3 Errors.res) -> ('a1, 'a2) Types.prod List.list -> ('a1, 'a3) + Types.prod List.list Errors.res + +val transform_partial_program : + ('a1, 'a3) program -> (ident List.list -> 'a1 -> 'a2 Errors.res) -> ('a2, + 'a3) program Errors.res + +val transform_partial_program2 : + ('a1, 'a3) program -> (ident List.list -> 'a1 -> 'a2 Errors.res) -> ('a3 -> + 'a4 Errors.res) -> ('a2, 'a4) program Errors.res + +type matching = +| Mk_matching + +val matching_rect_Type4 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 + +val matching_rect_Type5 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 + +val matching_rect_Type3 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 + +val matching_rect_Type2 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 + +val matching_rect_Type1 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 + +val matching_rect_Type0 : + (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> matching -> 'a1 + +type m_A + +type m_B + +type m_V + +type m_W + +val matching_inv_rect_Type4 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val matching_inv_rect_Type3 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val matching_inv_rect_Type2 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val matching_inv_rect_Type1 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val matching_inv_rect_Type0 : + matching -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val matching_jmdiscr : matching -> matching -> __ + +val mfe_cast_fn_type : + matching -> ident List.list -> ident List.list -> __ -> __ + +val match_program_rect_Type4 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> 'a1) + -> 'a1 + +val match_program_rect_Type5 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> 'a1) + -> 'a1 + +val match_program_rect_Type3 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> 'a1) + -> 'a1 + +val match_program_rect_Type2 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> 'a1) + -> 'a1 + +val match_program_rect_Type1 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> 'a1) + -> 'a1 + +val match_program_rect_Type0 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> 'a1) + -> 'a1 + +val match_program_inv_rect_Type4 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val match_program_inv_rect_Type3 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val match_program_inv_rect_Type2 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val match_program_inv_rect_Type1 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val match_program_inv_rect_Type0 : + matching -> (__, __) program -> (__, __) program -> (__ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val match_program_discr : + matching -> (__, __) program -> (__, __) program -> __ + +val match_program_jmdiscr : + matching -> (__, __) program -> (__, __) program -> __ + +type external_function = { ef_id : ident; ef_sig : signature } + +val external_function_rect_Type4 : + (ident -> signature -> 'a1) -> external_function -> 'a1 + +val external_function_rect_Type5 : + (ident -> signature -> 'a1) -> external_function -> 'a1 + +val external_function_rect_Type3 : + (ident -> signature -> 'a1) -> external_function -> 'a1 + +val external_function_rect_Type2 : + (ident -> signature -> 'a1) -> external_function -> 'a1 + +val external_function_rect_Type1 : + (ident -> signature -> 'a1) -> external_function -> 'a1 + +val external_function_rect_Type0 : + (ident -> signature -> 'a1) -> external_function -> 'a1 + +val ef_id : external_function -> ident + +val ef_sig : external_function -> signature + +val external_function_inv_rect_Type4 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 + +val external_function_inv_rect_Type3 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 + +val external_function_inv_rect_Type2 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 + +val external_function_inv_rect_Type1 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 + +val external_function_inv_rect_Type0 : + external_function -> (ident -> signature -> __ -> 'a1) -> 'a1 + +val external_function_discr : external_function -> external_function -> __ + +val external_function_jmdiscr : external_function -> external_function -> __ + +type externalFunction = external_function + +val external_function_tag : external_function -> ident + +val external_function_sig : external_function -> signature + +type 'f fundef = +| Internal of 'f +| External of external_function + +val fundef_rect_Type4 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 + +val fundef_rect_Type5 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 + +val fundef_rect_Type3 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 + +val fundef_rect_Type2 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 + +val fundef_rect_Type1 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 + +val fundef_rect_Type0 : + ('a1 -> 'a2) -> (external_function -> 'a2) -> 'a1 fundef -> 'a2 + +val fundef_inv_rect_Type4 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> 'a2 + +val fundef_inv_rect_Type3 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> 'a2 + +val fundef_inv_rect_Type2 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> 'a2 + +val fundef_inv_rect_Type1 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> 'a2 + +val fundef_inv_rect_Type0 : + 'a1 fundef -> ('a1 -> __ -> 'a2) -> (external_function -> __ -> 'a2) -> 'a2 + +val fundef_discr : 'a1 fundef -> 'a1 fundef -> __ + +val fundef_jmdiscr : 'a1 fundef -> 'a1 fundef -> __ + +val transf_fundef : ('a1 -> 'a2) -> 'a1 fundef -> 'a2 fundef + +val transf_partial_fundef : + ('a1 -> 'a2 Errors.res) -> 'a1 fundef -> 'a2 fundef Errors.res + diff --git a/extracted/abstractStatus.ml b/extracted/abstractStatus.ml new file mode 100644 index 0000000..61faf8d --- /dev/null +++ b/extracted/abstractStatus.ml @@ -0,0 +1,197 @@ +open Preamble + +open Hide + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Russell + +open Util + +open List + +open Lists + +open Nat + +open Positive + +open Types + +open Identifiers + +open CostLabel + +open Jmeq + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Bool + +open StructuredTraces + +open BitVectorTrie + +open String + +open LabelledObjects + +open ASM + +open Status + +open Fetch + +(** val aSM_classify00 : + 'a1 ASM.preinstruction -> StructuredTraces.status_class **) +let aSM_classify00 = function +| ASM.ADD (x, x0) -> StructuredTraces.Cl_other +| ASM.ADDC (x, x0) -> StructuredTraces.Cl_other +| ASM.SUBB (x, x0) -> StructuredTraces.Cl_other +| ASM.INC x -> StructuredTraces.Cl_other +| ASM.DEC x -> StructuredTraces.Cl_other +| ASM.MUL (x, x0) -> StructuredTraces.Cl_other +| ASM.DIV (x, x0) -> StructuredTraces.Cl_other +| ASM.DA x -> StructuredTraces.Cl_other +| ASM.JC x -> StructuredTraces.Cl_jump +| ASM.JNC x -> StructuredTraces.Cl_jump +| ASM.JB (x, x0) -> StructuredTraces.Cl_jump +| ASM.JNB (x, x0) -> StructuredTraces.Cl_jump +| ASM.JBC (x, x0) -> StructuredTraces.Cl_jump +| ASM.JZ x -> StructuredTraces.Cl_jump +| ASM.JNZ x -> StructuredTraces.Cl_jump +| ASM.CJNE (x, x0) -> StructuredTraces.Cl_jump +| ASM.DJNZ (x, x0) -> StructuredTraces.Cl_jump +| ASM.ANL x -> StructuredTraces.Cl_other +| ASM.ORL x -> StructuredTraces.Cl_other +| ASM.XRL x -> StructuredTraces.Cl_other +| ASM.CLR x -> StructuredTraces.Cl_other +| ASM.CPL x -> StructuredTraces.Cl_other +| ASM.RL x -> StructuredTraces.Cl_other +| ASM.RLC x -> StructuredTraces.Cl_other +| ASM.RR x -> StructuredTraces.Cl_other +| ASM.RRC x -> StructuredTraces.Cl_other +| ASM.SWAP x -> StructuredTraces.Cl_other +| ASM.MOV x -> StructuredTraces.Cl_other +| ASM.MOVX x -> StructuredTraces.Cl_other +| ASM.SETB x -> StructuredTraces.Cl_other +| ASM.PUSH x -> StructuredTraces.Cl_other +| ASM.POP x -> StructuredTraces.Cl_other +| ASM.XCH (x, x0) -> StructuredTraces.Cl_other +| ASM.XCHD (x, x0) -> StructuredTraces.Cl_other +| ASM.RET -> StructuredTraces.Cl_return +| ASM.RETI -> StructuredTraces.Cl_return +| ASM.NOP -> StructuredTraces.Cl_other +| ASM.JMP x -> StructuredTraces.Cl_call + +(** val aSM_classify0 : ASM.instruction -> StructuredTraces.status_class **) +let aSM_classify0 = function +| ASM.ACALL x -> StructuredTraces.Cl_call +| ASM.LCALL x -> StructuredTraces.Cl_call +| ASM.AJMP x -> StructuredTraces.Cl_other +| ASM.LJMP x -> StructuredTraces.Cl_other +| ASM.SJMP x -> StructuredTraces.Cl_other +| ASM.MOVC (x, x0) -> StructuredTraces.Cl_other +| ASM.RealInstruction pre -> aSM_classify00 pre + +(** val current_instruction0 : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + ASM.instruction **) +let current_instruction0 code_memory program_counter = + (Fetch.fetch code_memory program_counter).Types.fst.Types.fst + +(** val current_instruction : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + ASM.instruction **) +let current_instruction code_memory s = + current_instruction0 code_memory s.Status.program_counter + +(** val current_instruction_label : + BitVector.byte BitVectorTrie.bitVectorTrie -> CostLabel.costlabel + BitVectorTrie.bitVectorTrie -> Status.status -> CostLabel.costlabel + Types.option **) +let current_instruction_label code_memory cost_labels s = + let pc = s.Status.program_counter in + BitVectorTrie.lookup_opt (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) pc cost_labels + +(** val word_deqset : Deqsets.deqSet **) +let word_deqset = + Obj.magic + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) + +(** val oC_classify : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + StructuredTraces.status_class **) +let oC_classify code_memory s = + aSM_classify0 (current_instruction code_memory s) + diff --git a/extracted/abstractStatus.mli b/extracted/abstractStatus.mli new file mode 100644 index 0000000..fe82c6a --- /dev/null +++ b/extracted/abstractStatus.mli @@ -0,0 +1,133 @@ +open Preamble + +open Hide + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Russell + +open Util + +open List + +open Lists + +open Nat + +open Positive + +open Types + +open Identifiers + +open CostLabel + +open Jmeq + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Bool + +open StructuredTraces + +open BitVectorTrie + +open String + +open LabelledObjects + +open ASM + +open Status + +open Fetch + +val aSM_classify00 : 'a1 ASM.preinstruction -> StructuredTraces.status_class + +val aSM_classify0 : ASM.instruction -> StructuredTraces.status_class + +val current_instruction0 : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + ASM.instruction + +val current_instruction : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + ASM.instruction + +val current_instruction_label : + BitVector.byte BitVectorTrie.bitVectorTrie -> CostLabel.costlabel + BitVectorTrie.bitVectorTrie -> Status.status -> CostLabel.costlabel + Types.option + +val word_deqset : Deqsets.deqSet + +val oC_classify : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + StructuredTraces.status_class + diff --git a/extracted/arithmetic.ml b/extracted/arithmetic.ml new file mode 100644 index 0000000..1fa7485 --- /dev/null +++ b/extracted/arithmetic.ml @@ -0,0 +1,807 @@ +open Preamble + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open BitVector + +open Exp + +(** val addr16_of_addr11 : + BitVector.word -> BitVector.word11 -> BitVector.word **) +let addr16_of_addr11 pc a = + let { Types.fst = pc_upper; Types.snd = ignore } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) pc + in + let { Types.fst = n1; Types.snd = n2 } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))) pc_upper + in + let { Types.fst = b123; Types.snd = b } = + Vector.vsplit (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) a + in + let b1 = Vector.get_index_v (Nat.S (Nat.S (Nat.S Nat.O))) b123 Nat.O in + let b2 = + Vector.get_index_v (Nat.S (Nat.S (Nat.S Nat.O))) b123 (Nat.S Nat.O) + in + let b3 = + Vector.get_index_v (Nat.S (Nat.S (Nat.S Nat.O))) b123 (Nat.S (Nat.S + Nat.O)) + in + let p5 = Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) n2 Nat.O + in + Vector.append + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))) n1 (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), p5, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), b1, (Vector.VCons ((Nat.S Nat.O), + b2, (Vector.VCons (Nat.O, b3, Vector.VEmpty))))))))) b + +(** val nat_of_bool : Bool.bool -> Nat.nat **) +let nat_of_bool = function +| Bool.True -> Nat.S Nat.O +| Bool.False -> Nat.O + +(** val carry_of : Bool.bool -> Bool.bool -> Bool.bool -> Bool.bool **) +let carry_of a b c = + match a with + | Bool.True -> Bool.orb b c + | Bool.False -> Bool.andb b c + +(** val add_with_carries : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let add_with_carries n x y init_carry = + Vector.fold_right2_i (fun n0 b c r -> + let { Types.fst = lower_bits; Types.snd = carries } = r in + let last_carry = + match carries with + | Vector.VEmpty -> init_carry + | Vector.VCons (x0, cy, x1) -> cy + in + (match last_carry with + | Bool.True -> + let bit = Bool.xorb (Bool.xorb b c) Bool.True in + let carry = carry_of b c Bool.True in + { Types.fst = (Vector.VCons (n0, bit, lower_bits)); Types.snd = + (Vector.VCons (n0, carry, carries)) } + | Bool.False -> + let bit = Bool.xorb (Bool.xorb b c) Bool.False in + let carry = carry_of b c Bool.False in + { Types.fst = (Vector.VCons (n0, bit, lower_bits)); Types.snd = + (Vector.VCons (n0, carry, carries)) })) { Types.fst = Vector.VEmpty; + Types.snd = Vector.VEmpty } n x y + +(** val borrow_of : Bool.bool -> Bool.bool -> Bool.bool -> Bool.bool **) +let borrow_of a b c = + match a with + | Bool.True -> Bool.andb b c + | Bool.False -> Bool.orb b c + +(** val sub_with_borrows : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let sub_with_borrows n x y init_borrow = + Vector.fold_right2_i (fun n0 b c r -> + let { Types.fst = lower_bits; Types.snd = borrows } = r in + let last_borrow = + match borrows with + | Vector.VEmpty -> init_borrow + | Vector.VCons (x0, bw, x1) -> bw + in + let bit = Bool.xorb (Bool.xorb b c) last_borrow in + let borrow = borrow_of b c last_borrow in + { Types.fst = (Vector.VCons (n0, bit, lower_bits)); Types.snd = + (Vector.VCons (n0, borrow, borrows)) }) { Types.fst = Vector.VEmpty; + Types.snd = Vector.VEmpty } n x y + +(** val add_n_with_carry : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let add_n_with_carry n b c carry = + let { Types.fst = result; Types.snd = carries } = + add_with_carries n b c carry + in + let cy_flag = Vector.get_index_v n carries Nat.O in + let ov_flag = + Bool.xorb cy_flag (Vector.get_index_v n carries (Nat.S Nat.O)) + in + let ac_flag = + Vector.get_index_v n carries (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + in + { Types.fst = result; Types.snd = (Vector.VCons ((Nat.S (Nat.S Nat.O)), + cy_flag, (Vector.VCons ((Nat.S Nat.O), ac_flag, (Vector.VCons (Nat.O, + ov_flag, Vector.VEmpty)))))) } + +(** val sub_n_with_carry : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let sub_n_with_carry n b c carry = + let { Types.fst = result; Types.snd = carries } = + sub_with_borrows n b c carry + in + let cy_flag = Vector.get_index_v n carries Nat.O in + let ov_flag = + Bool.xorb cy_flag (Vector.get_index_v n carries (Nat.S Nat.O)) + in + let ac_flag = + Vector.get_index_v n carries (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + in + { Types.fst = result; Types.snd = (Vector.VCons ((Nat.S (Nat.S Nat.O)), + cy_flag, (Vector.VCons ((Nat.S Nat.O), ac_flag, (Vector.VCons (Nat.O, + ov_flag, Vector.VEmpty)))))) } + +(** val add_8_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let add_8_with_carry b c carry = + add_n_with_carry (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) b c carry + +(** val add_16_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let add_16_with_carry b c carry = + add_n_with_carry (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) b c carry + +(** val sub_7_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let sub_7_with_carry b c carry = + sub_n_with_carry (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) b c carry + +(** val sub_8_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let sub_8_with_carry b c carry = + sub_n_with_carry (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) b c carry + +(** val sub_16_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let sub_16_with_carry b c carry = + sub_n_with_carry (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) b c carry + +(** val increment : Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let increment n b = + (add_with_carries n b (BitVector.zero n) Bool.True).Types.fst + +(** val decrement : Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let decrement n b = + (sub_with_borrows n b (BitVector.zero n) Bool.True).Types.fst + +(** val bitvector_of_nat_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let rec bitvector_of_nat_aux n m v = + match m with + | Nat.O -> v + | Nat.S m' -> bitvector_of_nat_aux n m' (increment n v) + +(** val bitvector_of_nat : Nat.nat -> Nat.nat -> BitVector.bitVector **) +let bitvector_of_nat n m = + bitvector_of_nat_aux n m (BitVector.zero n) + +(** val nat_of_bitvector_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> Nat.nat **) +let rec nat_of_bitvector_aux n m = function +| Vector.VEmpty -> m +| Vector.VCons (n', hd, tl) -> + nat_of_bitvector_aux n' + (match hd with + | Bool.True -> + Nat.plus (Nat.times (Nat.S (Nat.S Nat.O)) m) (Nat.S Nat.O) + | Bool.False -> Nat.times (Nat.S (Nat.S Nat.O)) m) tl + +(** val nat_of_bitvector : Nat.nat -> BitVector.bitVector -> Nat.nat **) +let nat_of_bitvector n v = + nat_of_bitvector_aux n Nat.O v + +(** val two_complement_negation : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let two_complement_negation n b = + let new_b = BitVector.negation_bv n b in increment n new_b + +(** val addition_n : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector **) +let addition_n n b c = + (add_with_carries n b c Bool.False).Types.fst + +(** val subtraction : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector **) +let subtraction n b c = + addition_n n b (two_complement_negation n c) + +(** val mult_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector -> BitVector.bitVector **) +let rec mult_aux m n b c acc = + match b with + | Vector.VEmpty -> acc + | Vector.VCons (m', hd, tl) -> + let acc' = + match hd with + | Bool.True -> addition_n (Nat.S n) c acc + | Bool.False -> acc + in + mult_aux m' n tl (Vector.shift_right_1 n c Bool.False) acc' + +(** val multiplication : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector **) +let multiplication = function +| Nat.O -> (fun x x0 -> Vector.VEmpty) +| Nat.S m -> + (fun b c -> + let c' = BitVector.pad (Nat.S m) (Nat.S m) c in + mult_aux (Nat.S m) (Nat.plus m (Nat.S m)) b + (Vector.shift_left (Nat.plus (Nat.S m) (Nat.S m)) m c' Bool.False) + (BitVector.zero (Nat.S (Nat.plus m (Nat.S m))))) + +(** val short_multiplication : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector **) +let short_multiplication n x y = + (Vector.vsplit n n (multiplication n x y)).Types.snd + +type fbs_diff = +| Fbs_diff' of Nat.nat * Nat.nat + +(** val fbs_diff_rect_Type4 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 **) +let rec fbs_diff_rect_Type4 h_fbs_diff' x_1368 = function +| Fbs_diff' (n, m) -> h_fbs_diff' n m + +(** val fbs_diff_rect_Type5 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 **) +let rec fbs_diff_rect_Type5 h_fbs_diff' x_1371 = function +| Fbs_diff' (n, m) -> h_fbs_diff' n m + +(** val fbs_diff_rect_Type3 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 **) +let rec fbs_diff_rect_Type3 h_fbs_diff' x_1374 = function +| Fbs_diff' (n, m) -> h_fbs_diff' n m + +(** val fbs_diff_rect_Type2 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 **) +let rec fbs_diff_rect_Type2 h_fbs_diff' x_1377 = function +| Fbs_diff' (n, m) -> h_fbs_diff' n m + +(** val fbs_diff_rect_Type1 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 **) +let rec fbs_diff_rect_Type1 h_fbs_diff' x_1380 = function +| Fbs_diff' (n, m) -> h_fbs_diff' n m + +(** val fbs_diff_rect_Type0 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 **) +let rec fbs_diff_rect_Type0 h_fbs_diff' x_1383 = function +| Fbs_diff' (n, m) -> h_fbs_diff' n m + +(** val fbs_diff_inv_rect_Type4 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let fbs_diff_inv_rect_Type4 x1 hterm h1 = + let hcut = fbs_diff_rect_Type4 h1 x1 hterm in hcut __ __ + +(** val fbs_diff_inv_rect_Type3 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let fbs_diff_inv_rect_Type3 x1 hterm h1 = + let hcut = fbs_diff_rect_Type3 h1 x1 hterm in hcut __ __ + +(** val fbs_diff_inv_rect_Type2 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let fbs_diff_inv_rect_Type2 x1 hterm h1 = + let hcut = fbs_diff_rect_Type2 h1 x1 hterm in hcut __ __ + +(** val fbs_diff_inv_rect_Type1 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let fbs_diff_inv_rect_Type1 x1 hterm h1 = + let hcut = fbs_diff_rect_Type1 h1 x1 hterm in hcut __ __ + +(** val fbs_diff_inv_rect_Type0 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let fbs_diff_inv_rect_Type0 x1 hterm h1 = + let hcut = fbs_diff_rect_Type0 h1 x1 hterm in hcut __ __ + +(** val fbs_diff_discr : Nat.nat -> fbs_diff -> fbs_diff -> __ **) +let fbs_diff_discr a1 x y = + Logic.eq_rect_Type2 x + (let Fbs_diff' (a0, a10) = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val fbs_diff_jmdiscr : Nat.nat -> fbs_diff -> fbs_diff -> __ **) +let fbs_diff_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let Fbs_diff' (a0, a10) = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val first_bit_set : + Nat.nat -> BitVector.bitVector -> fbs_diff Types.option **) +let rec first_bit_set n = function +| Vector.VEmpty -> Types.None +| Vector.VCons (m, h, t) -> + (match h with + | Bool.True -> Types.Some (Fbs_diff' (Nat.O, m)) + | Bool.False -> + (match first_bit_set m t with + | Types.None -> Types.None + | Types.Some o -> + let Fbs_diff' (x, y) = o in Types.Some (Fbs_diff' ((Nat.S x), y)))) + +(** val divmod_u_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + (BitVector.bitVector, BitVector.bitVector) Types.prod **) +let rec divmod_u_aux n m q d = + match m with + | Nat.O -> { Types.fst = Vector.VEmpty; Types.snd = q } + | Nat.S m' -> + let { Types.fst = q'; Types.snd = flags } = + add_with_carries (Nat.S n) q (two_complement_negation (Nat.S n) d) + Bool.False + in + let bit = Vector.head' n flags in + let q'' = + match bit with + | Bool.True -> q' + | Bool.False -> q + in + let { Types.fst = tl; Types.snd = md } = + divmod_u_aux n m' q'' (Vector.shift_right_1 n d Bool.False) + in + { Types.fst = (Vector.VCons (m', bit, tl)); Types.snd = md } + +(** val divmod_u : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + (BitVector.bitVector, BitVector.bitVector) Types.prod Types.option **) +let divmod_u n b c = + match first_bit_set (Nat.S n) c with + | Types.None -> Types.None + | Types.Some fbs' -> + let Fbs_diff' (fbs, m) = fbs' in + let { Types.fst = d; Types.snd = m0 } = + divmod_u_aux n (Nat.S fbs) b + (Vector.shift_left (Nat.S n) fbs c Bool.False) + in + Types.Some { Types.fst = + (Vector.switch_bv_plus m (Nat.S fbs) (BitVector.pad m (Nat.S fbs) d)); + Types.snd = m0 } + +(** val division_u : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option **) +let division_u n q d = + match divmod_u n q d with + | Types.None -> Types.None + | Types.Some p -> Types.Some p.Types.fst + +(** val division_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option **) +let division_s = function +| Nat.O -> (fun b c -> Types.None) +| Nat.S p -> + (fun b c -> + let b_sign_bit = Vector.get_index_v (Nat.S p) b Nat.O in + let c_sign_bit = Vector.get_index_v (Nat.S p) c Nat.O in + (match b_sign_bit with + | Bool.True -> + let neg_b = two_complement_negation (Nat.S p) b in + (match c_sign_bit with + | Bool.True -> + division_u p neg_b (two_complement_negation (Nat.S p) c) + | Bool.False -> + (match division_u p neg_b c with + | Types.None -> Types.None + | Types.Some r -> Types.Some (two_complement_negation (Nat.S p) r))) + | Bool.False -> + (match c_sign_bit with + | Bool.True -> + (match division_u p b (two_complement_negation (Nat.S p) c) with + | Types.None -> Types.None + | Types.Some r -> Types.Some (two_complement_negation (Nat.S p) r)) + | Bool.False -> division_u p b c))) + +(** val modulus_u : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option **) +let modulus_u n q d = + match divmod_u n q d with + | Types.None -> Types.None + | Types.Some p -> Types.Some p.Types.snd + +(** val modulus_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option **) +let modulus_s n b c = + match division_s n b c with + | Types.None -> Types.None + | Types.Some result -> + let { Types.fst = high_bits; Types.snd = low_bits } = + Vector.vsplit n n (multiplication n result c) + in + Types.Some (subtraction n b low_bits) + +(** val lt_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> + Bool.bool **) +let lt_u = + Vector.fold_right2_i (fun x a b r -> + match a with + | Bool.True -> Bool.andb b r + | Bool.False -> Bool.orb b r) Bool.False + +(** val gt_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> + Bool.bool **) +let gt_u n b c = + lt_u n c b + +(** val lte_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> + Bool.bool **) +let lte_u n b c = + Bool.notb (gt_u n b c) + +(** val gte_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> + Bool.bool **) +let gte_u n b c = + Bool.notb (lt_u n b c) + +(** val lt_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool **) +let lt_s n b c = + let { Types.fst = result; Types.snd = borrows } = + sub_with_borrows n b c Bool.False + in + (match borrows with + | Vector.VEmpty -> Bool.False + | Vector.VCons (x, bwn, tl) -> + (match tl with + | Vector.VEmpty -> Bool.False + | Vector.VCons (x0, bwpn, x1) -> + (match Bool.xorb bwn bwpn with + | Bool.True -> + (match result with + | Vector.VEmpty -> Bool.False + | Vector.VCons (x2, b7, x3) -> b7) + | Bool.False -> + (match result with + | Vector.VEmpty -> Bool.False + | Vector.VCons (x2, b7, x3) -> b7)))) + +(** val gt_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool **) +let gt_s n b c = + lt_s n c b + +(** val lte_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool **) +let lte_s n b c = + Bool.notb (gt_s n b c) + +(** val gte_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool **) +let gte_s n b c = + Bool.notb (lt_s n b c) + +type ternary = +| Zero_carry +| One_carry +| Two_carry + +(** val ternary_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 **) +let rec ternary_rect_Type4 h_Zero_carry h_One_carry h_Two_carry = function +| Zero_carry -> h_Zero_carry +| One_carry -> h_One_carry +| Two_carry -> h_Two_carry + +(** val ternary_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 **) +let rec ternary_rect_Type5 h_Zero_carry h_One_carry h_Two_carry = function +| Zero_carry -> h_Zero_carry +| One_carry -> h_One_carry +| Two_carry -> h_Two_carry + +(** val ternary_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 **) +let rec ternary_rect_Type3 h_Zero_carry h_One_carry h_Two_carry = function +| Zero_carry -> h_Zero_carry +| One_carry -> h_One_carry +| Two_carry -> h_Two_carry + +(** val ternary_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 **) +let rec ternary_rect_Type2 h_Zero_carry h_One_carry h_Two_carry = function +| Zero_carry -> h_Zero_carry +| One_carry -> h_One_carry +| Two_carry -> h_Two_carry + +(** val ternary_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 **) +let rec ternary_rect_Type1 h_Zero_carry h_One_carry h_Two_carry = function +| Zero_carry -> h_Zero_carry +| One_carry -> h_One_carry +| Two_carry -> h_Two_carry + +(** val ternary_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 **) +let rec ternary_rect_Type0 h_Zero_carry h_One_carry h_Two_carry = function +| Zero_carry -> h_Zero_carry +| One_carry -> h_One_carry +| Two_carry -> h_Two_carry + +(** val ternary_inv_rect_Type4 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let ternary_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = ternary_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val ternary_inv_rect_Type3 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let ternary_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = ternary_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val ternary_inv_rect_Type2 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let ternary_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = ternary_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val ternary_inv_rect_Type1 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let ternary_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = ternary_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val ternary_inv_rect_Type0 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let ternary_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = ternary_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val ternary_discr : ternary -> ternary -> __ **) +let ternary_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Zero_carry -> Obj.magic (fun _ dH -> dH) + | One_carry -> Obj.magic (fun _ dH -> dH) + | Two_carry -> Obj.magic (fun _ dH -> dH)) y + +(** val ternary_jmdiscr : ternary -> ternary -> __ **) +let ternary_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Zero_carry -> Obj.magic (fun _ dH -> dH) + | One_carry -> Obj.magic (fun _ dH -> dH) + | Two_carry -> Obj.magic (fun _ dH -> dH)) y + +(** val carry_0 : ternary -> (Bool.bool, ternary) Types.prod **) +let carry_0 = function +| Zero_carry -> { Types.fst = Bool.False; Types.snd = Zero_carry } +| One_carry -> { Types.fst = Bool.True; Types.snd = Zero_carry } +| Two_carry -> { Types.fst = Bool.False; Types.snd = One_carry } + +(** val carry_1 : ternary -> (Bool.bool, ternary) Types.prod **) +let carry_1 = function +| Zero_carry -> { Types.fst = Bool.True; Types.snd = Zero_carry } +| One_carry -> { Types.fst = Bool.False; Types.snd = One_carry } +| Two_carry -> { Types.fst = Bool.True; Types.snd = One_carry } + +(** val carry_2 : ternary -> (Bool.bool, ternary) Types.prod **) +let carry_2 = function +| Zero_carry -> { Types.fst = Bool.False; Types.snd = One_carry } +| One_carry -> { Types.fst = Bool.True; Types.snd = One_carry } +| Two_carry -> { Types.fst = Bool.False; Types.snd = Two_carry } + +(** val carry_3 : ternary -> (Bool.bool, ternary) Types.prod **) +let carry_3 = function +| Zero_carry -> { Types.fst = Bool.True; Types.snd = One_carry } +| One_carry -> { Types.fst = Bool.False; Types.snd = Two_carry } +| Two_carry -> { Types.fst = Bool.True; Types.snd = Two_carry } + +(** val ternary_carry_of : + Bool.bool -> Bool.bool -> Bool.bool -> ternary -> (Bool.bool, ternary) + Types.prod **) +let ternary_carry_of xa xb xc carry = + match xa with + | Bool.True -> + (match xb with + | Bool.True -> + (match xc with + | Bool.True -> carry_3 carry + | Bool.False -> carry_2 carry) + | Bool.False -> + (match xc with + | Bool.True -> carry_2 carry + | Bool.False -> carry_1 carry)) + | Bool.False -> + (match xb with + | Bool.True -> + (match xc with + | Bool.True -> carry_2 carry + | Bool.False -> carry_1 carry) + | Bool.False -> + (match xc with + | Bool.True -> carry_1 carry + | Bool.False -> carry_0 carry)) + +(** val canonical_add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector -> ternary -> (BitVector.bitVector, ternary) + Types.prod **) +let rec canonical_add n a b c init = + (match a with + | Vector.VEmpty -> + (fun x x0 -> { Types.fst = Vector.VEmpty; Types.snd = init }) + | Vector.VCons (sz', xa, tla) -> + (fun b' c' -> + let xb = Vector.head' sz' b' in + let xc = Vector.head' sz' c' in + let tlb = Vector.tail sz' b' in + let tlc = Vector.tail sz' c' in + let { Types.fst = bits; Types.snd = last } = + canonical_add sz' tla tlb tlc init + in + let { Types.fst = bit; Types.snd = carry } = + ternary_carry_of xa xb xc last + in + { Types.fst = (Vector.VCons (sz', bit, bits)); Types.snd = carry })) b + c + +(** val carries_to_ternary : Bool.bool -> Bool.bool -> ternary **) +let carries_to_ternary carry1 carry2 = + match carry1 with + | Bool.True -> + (match carry2 with + | Bool.True -> Two_carry + | Bool.False -> One_carry) + | Bool.False -> + (match carry2 with + | Bool.True -> One_carry + | Bool.False -> Zero_carry) + +(** val max_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> + Bool.bool Vector.vector **) +let max_u n a b = + match lt_u n a b with + | Bool.True -> b + | Bool.False -> a + +(** val min_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> + Bool.bool Vector.vector **) +let min_u n a b = + match lt_u n a b with + | Bool.True -> a + | Bool.False -> b + +(** val max_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector **) +let max_s n a b = + match lt_s n a b with + | Bool.True -> b + | Bool.False -> a + +(** val min_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector **) +let min_s n a b = + match lt_s n a b with + | Bool.True -> a + | Bool.False -> b + +(** val bitvector_of_bool : Nat.nat -> Bool.bool -> BitVector.bitVector **) +let bitvector_of_bool n b = + BitVector.pad n (Nat.S Nat.O) (Vector.VCons (Nat.O, b, Vector.VEmpty)) + +(** val full_add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> BitVector.bit -> + (BitVector.bit, BitVector.bitVector) Types.prod **) +let full_add n b c d = + Vector.fold_right2_i (fun n0 b1 b2 d0 -> + let { Types.fst = c1; Types.snd = r } = d0 in + { Types.fst = + (Bool.orb (Bool.andb b1 b2) (Bool.andb c1 (Bool.orb b1 b2))); Types.snd = + (Vector.VCons (n0, (Bool.xorb (Bool.xorb b1 b2) c1), r)) }) { Types.fst = + d; Types.snd = Vector.VEmpty } n b c + +(** val half_add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> (BitVector.bit, + BitVector.bitVector) Types.prod **) +let half_add n b c = + full_add n b c Bool.False + +(** val add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector **) +let add n l r = + (half_add n l r).Types.snd + +(** val sign_extension : BitVector.byte -> BitVector.word **) +let sign_extension c = + let b = + Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) c Nat.O + in + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), b, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), b, (Vector.VCons ((Nat.S Nat.O), b, (Vector.VCons (Nat.O, + b, Vector.VEmpty)))))))))))))))) c + +(** val sign_bit : Nat.nat -> BitVector.bitVector -> Bool.bool **) +let sign_bit n = function +| Vector.VEmpty -> Bool.False +| Vector.VCons (x, h, x0) -> h + +(** val sign_extend : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let sign_extend m n v = + Vector.pad_vector (sign_bit m v) n m v + +(** val zero_ext : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let zero_ext m n = + match Extranat.nat_compare m n with + | Extranat.Nat_lt (m', n') -> + (fun v -> + Vector.switch_bv_plus (Nat.S n') m' (BitVector.pad (Nat.S n') m' v)) + | Extranat.Nat_eq n' -> (fun v -> v) + | Extranat.Nat_gt (m', n') -> + (fun v -> + (Vector.vsplit (Nat.S m') n' (Vector.switch_bv_plus n' (Nat.S m') v)).Types.snd) + +(** val sign_ext : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let sign_ext m n = + match Extranat.nat_compare m n with + | Extranat.Nat_lt (m', n') -> + (fun v -> + Vector.switch_bv_plus (Nat.S n') m' (sign_extend m' (Nat.S n') v)) + | Extranat.Nat_eq n' -> (fun v -> v) + | Extranat.Nat_gt (m', n') -> + (fun v -> + (Vector.vsplit (Nat.S m') n' (Vector.switch_bv_plus n' (Nat.S m') v)).Types.snd) + diff --git a/extracted/arithmetic.mli b/extracted/arithmetic.mli new file mode 100644 index 0000000..3578443 --- /dev/null +++ b/extracted/arithmetic.mli @@ -0,0 +1,310 @@ +open Preamble + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open BitVector + +open Exp + +val addr16_of_addr11 : BitVector.word -> BitVector.word11 -> BitVector.word + +val nat_of_bool : Bool.bool -> Nat.nat + +val carry_of : Bool.bool -> Bool.bool -> Bool.bool -> Bool.bool + +val add_with_carries : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val borrow_of : Bool.bool -> Bool.bool -> Bool.bool -> Bool.bool + +val sub_with_borrows : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val add_n_with_carry : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val sub_n_with_carry : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val add_8_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val add_16_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val sub_7_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val sub_8_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val sub_16_with_carry : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val increment : Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val decrement : Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val bitvector_of_nat_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val bitvector_of_nat : Nat.nat -> Nat.nat -> BitVector.bitVector + +val nat_of_bitvector_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> Nat.nat + +val nat_of_bitvector : Nat.nat -> BitVector.bitVector -> Nat.nat + +val two_complement_negation : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val addition_n : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector + +val subtraction : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector + +val mult_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector -> BitVector.bitVector + +val multiplication : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector + +val short_multiplication : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector + +type fbs_diff = +| Fbs_diff' of Nat.nat * Nat.nat + +val fbs_diff_rect_Type4 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 + +val fbs_diff_rect_Type5 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 + +val fbs_diff_rect_Type3 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 + +val fbs_diff_rect_Type2 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 + +val fbs_diff_rect_Type1 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 + +val fbs_diff_rect_Type0 : + (Nat.nat -> Nat.nat -> 'a1) -> Nat.nat -> fbs_diff -> 'a1 + +val fbs_diff_inv_rect_Type4 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val fbs_diff_inv_rect_Type3 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val fbs_diff_inv_rect_Type2 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val fbs_diff_inv_rect_Type1 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val fbs_diff_inv_rect_Type0 : + Nat.nat -> fbs_diff -> (Nat.nat -> Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val fbs_diff_discr : Nat.nat -> fbs_diff -> fbs_diff -> __ + +val fbs_diff_jmdiscr : Nat.nat -> fbs_diff -> fbs_diff -> __ + +val first_bit_set : Nat.nat -> BitVector.bitVector -> fbs_diff Types.option + +val divmod_u_aux : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + (BitVector.bitVector, BitVector.bitVector) Types.prod + +val divmod_u : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + (BitVector.bitVector, BitVector.bitVector) Types.prod Types.option + +val division_u : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option + +val division_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option + +val modulus_u : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option + +val modulus_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector Types.option + +val lt_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> Bool.bool + +val gt_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> Bool.bool + +val lte_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> Bool.bool + +val gte_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> Bool.bool + +val lt_s : Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool + +val gt_s : Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool + +val lte_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool + +val gte_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool + +type ternary = +| Zero_carry +| One_carry +| Two_carry + +val ternary_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 + +val ternary_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 + +val ternary_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 + +val ternary_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 + +val ternary_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 + +val ternary_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> ternary -> 'a1 + +val ternary_inv_rect_Type4 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val ternary_inv_rect_Type3 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val ternary_inv_rect_Type2 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val ternary_inv_rect_Type1 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val ternary_inv_rect_Type0 : + ternary -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val ternary_discr : ternary -> ternary -> __ + +val ternary_jmdiscr : ternary -> ternary -> __ + +val carry_0 : ternary -> (Bool.bool, ternary) Types.prod + +val carry_1 : ternary -> (Bool.bool, ternary) Types.prod + +val carry_2 : ternary -> (Bool.bool, ternary) Types.prod + +val carry_3 : ternary -> (Bool.bool, ternary) Types.prod + +val ternary_carry_of : + Bool.bool -> Bool.bool -> Bool.bool -> ternary -> (Bool.bool, ternary) + Types.prod + +val canonical_add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector -> ternary -> (BitVector.bitVector, ternary) Types.prod + +val carries_to_ternary : Bool.bool -> Bool.bool -> ternary + +val max_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> Bool.bool + Vector.vector + +val min_u : + Nat.nat -> Bool.bool Vector.vector -> Bool.bool Vector.vector -> Bool.bool + Vector.vector + +val max_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector + +val min_s : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector + +val bitvector_of_bool : Nat.nat -> Bool.bool -> BitVector.bitVector + +val full_add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> BitVector.bit -> + (BitVector.bit, BitVector.bitVector) Types.prod + +val half_add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> (BitVector.bit, + BitVector.bitVector) Types.prod + +val add : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> + BitVector.bitVector + +val sign_extension : BitVector.byte -> BitVector.word + +val sign_bit : Nat.nat -> BitVector.bitVector -> Bool.bool + +val sign_extend : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val zero_ext : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val sign_ext : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + diff --git a/extracted/assembly.ml b/extracted/assembly.ml new file mode 100644 index 0000000..a001ff9 --- /dev/null +++ b/extracted/assembly.ml @@ -0,0 +1,3275 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open BitVectorTrie + +open String + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Arithmetic + +open Fetch + +open Status + +type jump_length = +| Short_jump +| Absolute_jump +| Long_jump + +(** val jump_length_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 **) +let rec jump_length_rect_Type4 h_short_jump h_absolute_jump h_long_jump = function +| Short_jump -> h_short_jump +| Absolute_jump -> h_absolute_jump +| Long_jump -> h_long_jump + +(** val jump_length_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 **) +let rec jump_length_rect_Type5 h_short_jump h_absolute_jump h_long_jump = function +| Short_jump -> h_short_jump +| Absolute_jump -> h_absolute_jump +| Long_jump -> h_long_jump + +(** val jump_length_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 **) +let rec jump_length_rect_Type3 h_short_jump h_absolute_jump h_long_jump = function +| Short_jump -> h_short_jump +| Absolute_jump -> h_absolute_jump +| Long_jump -> h_long_jump + +(** val jump_length_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 **) +let rec jump_length_rect_Type2 h_short_jump h_absolute_jump h_long_jump = function +| Short_jump -> h_short_jump +| Absolute_jump -> h_absolute_jump +| Long_jump -> h_long_jump + +(** val jump_length_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 **) +let rec jump_length_rect_Type1 h_short_jump h_absolute_jump h_long_jump = function +| Short_jump -> h_short_jump +| Absolute_jump -> h_absolute_jump +| Long_jump -> h_long_jump + +(** val jump_length_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 **) +let rec jump_length_rect_Type0 h_short_jump h_absolute_jump h_long_jump = function +| Short_jump -> h_short_jump +| Absolute_jump -> h_absolute_jump +| Long_jump -> h_long_jump + +(** val jump_length_inv_rect_Type4 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let jump_length_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = jump_length_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val jump_length_inv_rect_Type3 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let jump_length_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = jump_length_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val jump_length_inv_rect_Type2 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let jump_length_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = jump_length_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val jump_length_inv_rect_Type1 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let jump_length_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = jump_length_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val jump_length_inv_rect_Type0 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let jump_length_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = jump_length_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val jump_length_discr : jump_length -> jump_length -> __ **) +let jump_length_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Short_jump -> Obj.magic (fun _ dH -> dH) + | Absolute_jump -> Obj.magic (fun _ dH -> dH) + | Long_jump -> Obj.magic (fun _ dH -> dH)) y + +(** val jump_length_jmdiscr : jump_length -> jump_length -> __ **) +let jump_length_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Short_jump -> Obj.magic (fun _ dH -> dH) + | Absolute_jump -> Obj.magic (fun _ dH -> dH) + | Long_jump -> Obj.magic (fun _ dH -> dH)) y + +(** val short_jump_cond : + BitVector.word -> BitVector.word -> (Bool.bool, BitVector.bitVector) + Types.prod **) +let short_jump_cond pc_plus_jmp_length addr = + let { Types.fst = result; Types.snd = flags } = + Arithmetic.sub_16_with_carry addr pc_plus_jmp_length Bool.False + in + let { Types.fst = upper; Types.snd = lower } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) result + in + (match Vector.get_index' (Nat.S (Nat.S Nat.O)) Nat.O flags with + | Bool.True -> + { Types.fst = + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) upper (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty))))))))))))))))))); + Types.snd = (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), Bool.True, lower)) } + | Bool.False -> + { Types.fst = + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) upper + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))))); Types.snd = (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, + lower)) }) + +(** val absolute_jump_cond : + BitVector.word -> BitVector.word -> (Bool.bool, BitVector.bitVector) + Types.prod **) +let absolute_jump_cond pc_plus_jmp_length addr = + let { Types.fst = fst_5_addr; Types.snd = rest_addr } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))) addr + in + let { Types.fst = fst_5_pc; Types.snd = rest_pc } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))) pc_plus_jmp_length + in + { Types.fst = + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) fst_5_addr + fst_5_pc); Types.snd = rest_addr } + +(** val assembly_preinstruction : + ('a1 -> BitVector.byte) -> 'a1 ASM.preinstruction -> Bool.bool + Vector.vector List.list **) +let assembly_preinstruction addr_of = function +| ASM.ADD (addr1, addr2) -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S Nat.O), + ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S + (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.ADDC (addr1, addr2) -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S Nat.O), + ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S + (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.SUBB (addr1, addr2) -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S Nat.O), + ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S + (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.INC addr -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons + ((Nat.S Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Dptr, + Vector.VEmpty)))))))))) addr with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S + (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.DEC addr -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Registr, (Vector.VCons ((Nat.S Nat.O), + ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))))) addr with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S + (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.MUL (addr1, addr2) -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.DIV (addr1, addr2) -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.DA addr -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.JC addr -> + let b1 = addr_of addr in + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil))) +| ASM.JNC addr -> + let b1 = addr_of addr in + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil))) +| ASM.JB (addr1, addr2) -> + let b2 = addr_of addr2 in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) addr1 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, (List.Cons (b2, + List.Nil)))))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.JNB (addr1, addr2) -> + let b2 = addr_of addr2 in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) addr1 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, (List.Cons (b2, + List.Nil)))))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.JBC (addr1, addr2) -> + let b2 = addr_of addr2 in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) addr1 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, (List.Cons (b2, + List.Nil)))))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.JZ addr -> + let b1 = addr_of addr in + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil))) +| ASM.JNZ addr -> + let b1 = addr_of addr in + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil))) +| ASM.CJNE (addrs, addr3) -> + let b3 = addr_of addr3 in + (match addrs with + | Types.Inl addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + (List.Cons (b3, List.Nil)))))) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + (List.Cons (b3, List.Nil)))))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + | Types.Inr addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + let b2 = + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b2 -> (fun _ -> b2) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Registr, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))) addr1 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), (List.Cons (b2, (List.Cons (b3, + List.Nil)))))) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty)))))))))) r), + (List.Cons (b2, (List.Cons (b3, List.Nil)))))) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.DJNZ (addr1, addr2) -> + let b2 = addr_of addr2 in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Direct, Vector.VEmpty)))) + addr1 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, (List.Cons (b2, + List.Nil)))))) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S + (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty)))))))))) r), (List.Cons (b2, List.Nil)))) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.ANL addrs -> + (match addrs with + | Types.Inl addrs0 -> + (match addrs0 with + | Types.Inl addrs1 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs1 in + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Direct, + (Vector.VCons ((Nat.S Nat.O), ASM.Indirect, (Vector.VCons + (Nat.O, ASM.Data, Vector.VEmpty)))))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, i1, Vector.VEmpty)))))))))))))))), + List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S Nat.O), + Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + | Types.Inr addrs1 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs1 in + let b1 = + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Direct, Vector.VEmpty)) addr1 with + | ASM.DIRECT b1 -> (fun _ -> b1) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b2 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, (List.Cons (b2, List.Nil)))))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | Types.Inr addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Bit_addr, (Vector.VCons (Nat.O, ASM.N_bit_addr, + Vector.VEmpty)))) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.N_BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.ORL addrs -> + (match addrs with + | Types.Inl addrs0 -> + (match addrs0 with + | Types.Inl addrs1 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs1 in + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Data, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons + (Nat.O, ASM.Indirect, Vector.VEmpty)))))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, i1, Vector.VEmpty)))))))))))))))), + List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S Nat.O), + Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + | Types.Inr addrs1 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs1 in + let b1 = + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Direct, Vector.VEmpty)) addr1 with + | ASM.DIRECT b1 -> (fun _ -> b1) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b2 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, (List.Cons (b2, List.Nil)))))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | Types.Inr addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Bit_addr, (Vector.VCons (Nat.O, ASM.N_bit_addr, + Vector.VEmpty)))) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.N_BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.XRL addrs -> + (match addrs with + | Types.Inl addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Data, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Registr, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons (Nat.O, + ASM.Indirect, Vector.VEmpty)))))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty)))))))))) r), + List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + | Types.Inr addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + let b1 = + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Direct, Vector.VEmpty)) addr1 with + | ASM.DIRECT b1 -> (fun _ -> b1) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b2 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + (List.Cons (b2, List.Nil)))))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.CLR addr -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S Nat.O), + ASM.Carry, (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)))))) + addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.CPL addr -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S Nat.O), + ASM.Carry, (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)))))) + addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.RL addr -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.RLC addr -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.RR addr -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.RRC addr -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.SWAP addr -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.MOV addrs -> + (match addrs with + | Types.Inl addrs0 -> + (match addrs0 with + | Types.Inl addrs1 -> + (match addrs1 with + | Types.Inl addrs2 -> + (match addrs2 with + | Types.Inl addrs3 -> + (match addrs3 with + | Types.Inl addrs4 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs4 in + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S + Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S Nat.O), + ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))) (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> + (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> + (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) + __ + | Types.Inr addrs4 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs4 in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons + ((Nat.S Nat.O), ASM.Registr, (Vector.VCons (Nat.O, + ASM.Indirect, Vector.VEmpty)))) addr1 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT i1 -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_a, (Vector.VCons ((Nat.S Nat.O), + ASM.Direct, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.INDIRECT x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.ACC_B -> + (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.DATA16 x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> + (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x0 -> + (fun _ -> assert false (* absurd case *))) __) + | ASM.EXT_INDIRECT x -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_a, (Vector.VCons ((Nat.S Nat.O), + ASM.Direct, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))) (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))) r), (List.Cons (b1, + List.Nil)))) + | ASM.INDIRECT x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))) (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_B -> + (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.DATA b1 -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))) (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), + Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))) r), (List.Cons (b1, + List.Nil)))) + | ASM.DATA16 x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> + (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x0 -> + (fun _ -> assert false (* absurd case *))) __) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> + (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> + (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) + __) + | Types.Inr addrs3 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs3 in + let b1 = + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Direct, Vector.VEmpty)) addr1 with + | ASM.DIRECT b1 -> (fun _ -> b1) + | ASM.INDIRECT x -> + (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> + (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> + (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> + (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) + __ + in + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S + Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))))) addr2 with + | ASM.DIRECT b2 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, (List.Cons (b2, List.Nil)))))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons + (Nat.O, i1, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.EXT_INDIRECT x -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))) (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))) r), (List.Cons (b1, + List.Nil)))) + | ASM.ACC_A -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b2 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, (List.Cons (b2, List.Nil)))))) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) + __) + | Types.Inr addrs2 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs2 in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Data16, Vector.VEmpty)) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 w -> + (fun _ -> + let b1_b2 = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) w + in + let b1 = b1_b2.Types.fst in + let b2 = b1_b2.Types.snd in + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, (List.Cons + (b2, List.Nil)))))) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | Types.Inr addrs1 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs1 in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Bit_addr, Vector.VEmpty)) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, List.Nil)))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | Types.Inr addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Bit_addr, Vector.VEmpty)) addr1 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), (List.Cons (b1, + List.Nil)))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.MOVX addrs -> + (match addrs with + | Types.Inl addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + | Types.Inr addrs0 -> + let { Types.fst = addr1; Types.snd = addr2 } = addrs0 in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))) addr1 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.SETB addr -> + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + ASM.Carry, (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)))) + addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.BIT_ADDR b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.PUSH addr -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) addr with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.POP addr -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) addr with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.XCH (addr1, addr2) -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Registr, (Vector.VCons ((Nat.S Nat.O), + ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))) addr2 with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) (Nat.S + (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + Bool.True, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty)))))))))) r), List.Nil)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.XCHD (addr1, addr2) -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT i1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, (Vector.VCons ((Nat.S + Nat.O), Bool.True, (Vector.VCons (Nat.O, i1, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.RET -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.RETI -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.NOP -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty)))))))))))))))), List.Nil) +| ASM.JMP adptr -> + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil) + +(** val assembly1 : ASM.instruction -> Bool.bool Vector.vector List.list **) +let assembly1 = function +| ASM.ACALL addr -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Addr11, + Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 w -> + (fun _ -> + let v1_v2 = + Vector.vsplit (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) w + in + let v1 = v1_v2.Types.fst in + let v2 = v1_v2.Types.snd in + List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))) v1 (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.True, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty))))))))))), (List.Cons (v2, + List.Nil)))) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.LCALL addr -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Addr16, + Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 w -> + (fun _ -> + let b1_b2 = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) w + in + let b1 = b1_b2.Types.fst in + let b2 = b1_b2.Types.snd in + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, (List.Cons (b2, List.Nil))))))) __ +| ASM.AJMP addr -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Addr11, + Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 w -> + (fun _ -> + let v1_v2 = + Vector.vsplit (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) w + in + let v1 = v1_v2.Types.fst in + let v2 = v1_v2.Types.snd in + List.Cons + ((Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))) v1 (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), Bool.False, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty))))))))))), (List.Cons (v2, + List.Nil)))) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.LJMP addr -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Addr16, + Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 w -> + (fun _ -> + let b1_b2 = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) w + in + let b1 = b1_b2.Types.fst in + let b2 = b1_b2.Types.snd in + List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), Bool.False, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))))))))))))), + (List.Cons (b1, (List.Cons (b2, List.Nil))))))) __ +| ASM.SJMP addr -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Relative, + Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE b1 -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))))))))))))), (List.Cons (b1, List.Nil)))) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.MOVC (addr1, addr2) -> + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + ASM.Acc_dptr, (Vector.VCons (Nat.O, ASM.Acc_pc, Vector.VEmpty)))) + addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.True, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.ACC_PC -> + (fun _ -> List.Cons ((Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), Bool.True, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.False, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons + ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))))))))))))), List.Nil)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ +| ASM.RealInstruction instr -> + assembly_preinstruction (fun x -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Relative, + Vector.VEmpty)) x with + | ASM.DIRECT x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE r -> (fun _ -> r) + | ASM.ADDR11 x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x0 -> (fun _ -> assert false (* absurd case *))) __) instr + +(** val expand_relative_jump_internal : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) + -> (BitVector.word -> Bool.bool) -> ASM.identifier -> BitVector.word -> + (ASM.subaddressing_mode -> ASM.subaddressing_mode ASM.preinstruction) -> + ASM.instruction List.list **) +let expand_relative_jump_internal lookup_labels sigma policy lbl ppc i = + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match Bool.andb sj_possible (Bool.notb (policy ppc)) with + | Bool.True -> + let address = ASM.RELATIVE disp in + List.Cons ((ASM.RealInstruction (i address)), List.Nil) + | Bool.False -> + List.Cons ((ASM.RealInstruction + (i (ASM.RELATIVE + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S Nat.O)))))), + (List.Cons ((ASM.SJMP (ASM.RELATIVE + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S Nat.O)))))), + (List.Cons ((ASM.LJMP (ASM.ADDR16 lookup_address)), List.Nil)))))) + +(** val expand_relative_jump : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) + -> (BitVector.word -> Bool.bool) -> BitVector.word -> ASM.identifier + ASM.preinstruction -> ASM.instruction List.list **) +let expand_relative_jump lookup_labels sigma policy ppc = function +| ASM.ADD (arg1, arg2) -> + List.Cons ((ASM.RealInstruction (ASM.ADD (arg1, arg2))), List.Nil) +| ASM.ADDC (arg1, arg2) -> + List.Cons ((ASM.RealInstruction (ASM.ADDC (arg1, arg2))), List.Nil) +| ASM.SUBB (arg1, arg2) -> + List.Cons ((ASM.RealInstruction (ASM.SUBB (arg1, arg2))), List.Nil) +| ASM.INC arg -> List.Cons ((ASM.RealInstruction (ASM.INC arg)), List.Nil) +| ASM.DEC arg -> List.Cons ((ASM.RealInstruction (ASM.DEC arg)), List.Nil) +| ASM.MUL (arg1, arg2) -> + List.Cons ((ASM.RealInstruction (ASM.MUL (arg1, arg2))), List.Nil) +| ASM.DIV (arg1, arg2) -> + List.Cons ((ASM.RealInstruction (ASM.DIV (arg1, arg2))), List.Nil) +| ASM.DA arg -> List.Cons ((ASM.RealInstruction (ASM.DA arg)), List.Nil) +| ASM.JC jmp -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.JC x) +| ASM.JNC jmp -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.JNC x) +| ASM.JB (baddr, jmp) -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.JB (baddr, x)) +| ASM.JNB (baddr, jmp) -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.JNB (baddr, x)) +| ASM.JBC (baddr, jmp) -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.JBC (baddr, x)) +| ASM.JZ jmp -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.JZ x) +| ASM.JNZ jmp -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.JNZ x) +| ASM.CJNE (addr, jmp) -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.CJNE (addr, x)) +| ASM.DJNZ (addr, jmp) -> + expand_relative_jump_internal lookup_labels sigma policy jmp ppc (fun x -> + ASM.DJNZ (addr, x)) +| ASM.ANL arg -> List.Cons ((ASM.RealInstruction (ASM.ANL arg)), List.Nil) +| ASM.ORL arg -> List.Cons ((ASM.RealInstruction (ASM.ORL arg)), List.Nil) +| ASM.XRL arg -> List.Cons ((ASM.RealInstruction (ASM.XRL arg)), List.Nil) +| ASM.CLR arg -> List.Cons ((ASM.RealInstruction (ASM.CLR arg)), List.Nil) +| ASM.CPL arg -> List.Cons ((ASM.RealInstruction (ASM.CPL arg)), List.Nil) +| ASM.RL arg -> List.Cons ((ASM.RealInstruction (ASM.RL arg)), List.Nil) +| ASM.RLC arg -> List.Cons ((ASM.RealInstruction (ASM.RLC arg)), List.Nil) +| ASM.RR arg -> List.Cons ((ASM.RealInstruction (ASM.RR arg)), List.Nil) +| ASM.RRC arg -> List.Cons ((ASM.RealInstruction (ASM.RRC arg)), List.Nil) +| ASM.SWAP arg -> List.Cons ((ASM.RealInstruction (ASM.SWAP arg)), List.Nil) +| ASM.MOV arg -> List.Cons ((ASM.RealInstruction (ASM.MOV arg)), List.Nil) +| ASM.MOVX arg -> List.Cons ((ASM.RealInstruction (ASM.MOVX arg)), List.Nil) +| ASM.SETB arg -> List.Cons ((ASM.RealInstruction (ASM.SETB arg)), List.Nil) +| ASM.PUSH arg -> List.Cons ((ASM.RealInstruction (ASM.PUSH arg)), List.Nil) +| ASM.POP arg -> List.Cons ((ASM.RealInstruction (ASM.POP arg)), List.Nil) +| ASM.XCH (arg1, arg2) -> + List.Cons ((ASM.RealInstruction (ASM.XCH (arg1, arg2))), List.Nil) +| ASM.XCHD (arg1, arg2) -> + List.Cons ((ASM.RealInstruction (ASM.XCHD (arg1, arg2))), List.Nil) +| ASM.RET -> List.Cons ((ASM.RealInstruction ASM.RET), List.Nil) +| ASM.RETI -> List.Cons ((ASM.RealInstruction ASM.RETI), List.Nil) +| ASM.NOP -> List.Cons ((ASM.RealInstruction ASM.NOP), List.Nil) +| ASM.JMP arg -> List.Cons ((ASM.RealInstruction (ASM.JMP arg)), List.Nil) + +(** val is_code : AST.region -> Bool.bool **) +let is_code = function +| AST.XData -> Bool.False +| AST.Code -> Bool.True + +(** val expand_pseudo_instruction : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) + -> (BitVector.word -> Bool.bool) -> BitVector.word -> (ASM.identifier -> + (AST.region, BitVector.word) Types.prod) -> ASM.pseudo_instruction -> + ASM.instruction List.list **) +let expand_pseudo_instruction lookup_labels sigma policy ppc lookup_datalabels = function +| ASM.Instruction instr -> + expand_relative_jump lookup_labels sigma policy ppc instr +| ASM.Comment comment -> List.Nil +| ASM.Cost cost -> List.Cons ((ASM.RealInstruction ASM.NOP), List.Nil) +| ASM.Jmp jmp -> + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let do_a_long = policy ppc in + let lookup_address = sigma (lookup_labels jmp) in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match Bool.andb sj_possible (Bool.notb do_a_long) with + | Bool.True -> + let address = ASM.RELATIVE disp in + List.Cons ((ASM.SJMP address), List.Nil) + | Bool.False -> + let { Types.fst = mj_possible; Types.snd = disp2 } = + absolute_jump_cond pc_plus_jmp_length lookup_address + in + (match Bool.andb mj_possible (Bool.notb do_a_long) with + | Bool.True -> + let address = ASM.ADDR11 disp2 in + List.Cons ((ASM.AJMP address), List.Nil) + | Bool.False -> + let address = ASM.ADDR16 lookup_address in + List.Cons ((ASM.LJMP address), List.Nil))) +| ASM.Jnz (acc, tgt1, tgt2) -> + let lookup_address1 = sigma (lookup_labels tgt1) in + let lookup_address2 = sigma (lookup_labels tgt2) in + List.Cons ((ASM.RealInstruction (ASM.JNZ (ASM.RELATIVE + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S Nat.O))))))), (List.Cons + ((ASM.LJMP (ASM.ADDR16 lookup_address2)), (List.Cons ((ASM.LJMP (ASM.ADDR16 + lookup_address1)), List.Nil))))) +| ASM.Call call -> + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let lookup_address = sigma (lookup_labels call) in + let { Types.fst = mj_possible; Types.snd = disp } = + absolute_jump_cond pc_plus_jmp_length lookup_address + in + let do_a_long = policy ppc in + (match Bool.andb mj_possible (Bool.notb do_a_long) with + | Bool.True -> + let address = ASM.ADDR11 disp in + List.Cons ((ASM.ACALL address), List.Nil) + | Bool.False -> + let address = ASM.ADDR16 lookup_address in + List.Cons ((ASM.LCALL address), List.Nil)) +| ASM.Mov (d, trgt, off) -> + let { Types.fst = r; Types.snd = addr } = lookup_datalabels trgt in + let addr0 = (Arithmetic.add_16_with_carry addr off Bool.False).Types.fst in + let addr1 = + match is_code r with + | Bool.True -> sigma addr0 + | Bool.False -> addr0 + in + (match d with + | Types.Inl x -> + let address = ASM.DATA16 addr1 in + List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inr { Types.fst = ASM.DPTR; Types.snd = address }))))), List.Nil) + | Types.Inr pr -> + let v = ASM.DATA + (match pr.Types.snd with + | ASM.HIGH -> + (Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) addr1).Types.fst + | ASM.LOW -> + (Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) addr1).Types.snd) + in + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Registr, + Vector.VEmpty)))))) pr.Types.fst with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = (ASM.DIRECT b1); + Types.snd = v })))))), List.Nil)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r0 -> + (fun _ -> List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.REGISTER r0); Types.snd = v }))))))), List.Nil)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inl (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = v }))))))), List.Nil)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + +(** val assembly_1_pseudoinstruction : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) + -> (BitVector.word -> Bool.bool) -> BitVector.word -> (ASM.identifier -> + (AST.region, BitVector.word) Types.prod) -> ASM.pseudo_instruction -> + (Nat.nat, Bool.bool Vector.vector List.list) Types.prod **) +let assembly_1_pseudoinstruction lookup_labels sigma policy ppc lookup_datalabels i = + let pseudos = + expand_pseudo_instruction lookup_labels sigma policy ppc + lookup_datalabels i + in + let mapped = List.map assembly1 pseudos in + let flattened = List.flatten mapped in + let pc_len = List.length flattened in + { Types.fst = pc_len; Types.snd = flattened } + +(** val instruction_size : + (ASM.identifier -> BitVector.word) -> (ASM.identifier -> (AST.region, + BitVector.word) Types.prod) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> BitVector.word -> ASM.pseudo_instruction + -> Nat.nat **) +let instruction_size lookup_labels lookup_datalabels sigma policy ppc i = + (assembly_1_pseudoinstruction lookup_labels sigma policy ppc + lookup_datalabels i).Types.fst + +(** val assembly : + ASM.pseudo_assembly_program -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> ASM.labelled_object_code Types.sig0 **) +let assembly p sigma policy = + (let { Types.fst = labels_to_ppc; Types.snd = ppc_to_costs } = + Fetch.create_label_cost_map p.ASM.code + in + (fun _ -> + let preamble = p.ASM.preamble in + let instr_list = p.ASM.code in + let datalabels = Status.construct_datalabels preamble in + let lookup_labels = fun x -> + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (Identifiers.lookup_def PreIdentifiers.ASMTag labels_to_ppc x Nat.O) + in + let lookup_datalabels = fun x -> + match Identifiers.lookup PreIdentifiers.ASMTag + (Status.construct_datalabels preamble) x with + | Types.None -> { Types.fst = AST.Code; Types.snd = (lookup_labels x) } + | Types.Some addr -> { Types.fst = AST.XData; Types.snd = addr } + in + (let { Types.fst = next_pc; Types.snd = revcode } = + Types.pi1 + (FoldStuff.foldl_strong instr_list (fun prefix hd tl _ ppc_code -> + (let { Types.fst = ppc; Types.snd = code } = Types.pi1 ppc_code in + (fun _ -> + (let { Types.fst = pc_delta; Types.snd = program } = + assembly_1_pseudoinstruction lookup_labels sigma policy ppc + lookup_datalabels hd.Types.snd + in + (fun _ -> + let new_ppc = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O)) + in + { Types.fst = new_ppc; Types.snd = + (List.append (List.reverse program) code) })) __)) __) { Types.fst = + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))); Types.snd = List.Nil }) + in + (fun _ -> + let code = List.reverse revcode in + { ASM.oc = code; ASM.cm = (ASM.load_code_memory code); ASM.costlabels = + (BitVectorTrie.fold (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (fun ppc cost pc_to_costs -> + BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (sigma ppc) cost pc_to_costs) ppc_to_costs + (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))); ASM.symboltable = + (Util.foldl (fun symboltable newident_oldident -> + let ppc = lookup_labels newident_oldident.Types.fst in + BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (sigma ppc) newident_oldident.Types.snd + symboltable) (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))) p.ASM.renamed_symbols); ASM.final_pc = + (sigma (lookup_labels p.ASM.final_label)) })) __)) __ + +(** val ticks_of_instruction : ASM.instruction -> Nat.nat **) +let ticks_of_instruction i = + let trivial_code_memory = assembly1 i in + let trivial_status = ASM.load_code_memory trivial_code_memory in + (Fetch.fetch trivial_status + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))).Types.snd + +(** val ticks_of0 : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (BitVector.word -> BitVector.word) -> (BitVector.word -> Bool.bool) -> + BitVector.word -> ASM.pseudo_instruction -> (Nat.nat, Nat.nat) Types.prod **) +let ticks_of0 program lookup_labels sigma policy ppc = function +| ASM.Instruction instr -> + (match instr with + | ASM.ADD (arg1, arg2) -> + let ticks = + ticks_of_instruction (ASM.RealInstruction (ASM.ADD (arg1, arg2))) + in + { Types.fst = ticks; Types.snd = ticks } + | ASM.ADDC (arg1, arg2) -> + let ticks = + ticks_of_instruction (ASM.RealInstruction (ASM.ADDC (arg1, arg2))) + in + { Types.fst = ticks; Types.snd = ticks } + | ASM.SUBB (arg1, arg2) -> + let ticks = + ticks_of_instruction (ASM.RealInstruction (ASM.SUBB (arg1, arg2))) + in + { Types.fst = ticks; Types.snd = ticks } + | ASM.INC arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.INC arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.DEC arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.DEC arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.MUL (arg1, arg2) -> + let ticks = + ticks_of_instruction (ASM.RealInstruction (ASM.MUL (arg1, arg2))) + in + { Types.fst = ticks; Types.snd = ticks } + | ASM.DIV (arg1, arg2) -> + let ticks = + ticks_of_instruction (ASM.RealInstruction (ASM.DIV (arg1, arg2))) + in + { Types.fst = ticks; Types.snd = ticks } + | ASM.DA arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.DA arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.JC lbl -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.JNC lbl -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.JB (bit, lbl) -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.JNB (bit, lbl) -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.JBC (bit, lbl) -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.JZ lbl -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.JNZ lbl -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.CJNE (arg, lbl) -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.DJNZ (arg, lbl) -> + let lookup_address = sigma (lookup_labels lbl) in + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match sj_possible with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | ASM.ANL arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.ANL arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.ORL arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.ORL arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.XRL arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.XRL arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.CLR arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.CLR arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.CPL arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.CPL arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.RL arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.RL arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.RLC arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.RLC arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.RR arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.RR arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.RRC arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.RRC arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.SWAP arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.SWAP arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.MOV arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.MOV arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.MOVX arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.MOVX arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.SETB arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.SETB arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.PUSH arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.PUSH arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.POP arg -> + let ticks = ticks_of_instruction (ASM.RealInstruction (ASM.POP arg)) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.XCH (arg1, arg2) -> + let ticks = + ticks_of_instruction (ASM.RealInstruction (ASM.XCH (arg1, arg2))) + in + { Types.fst = ticks; Types.snd = ticks } + | ASM.XCHD (arg1, arg2) -> + let ticks = + ticks_of_instruction (ASM.RealInstruction (ASM.XCHD (arg1, arg2))) + in + { Types.fst = ticks; Types.snd = ticks } + | ASM.RET -> + let ticks = ticks_of_instruction (ASM.RealInstruction ASM.RET) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.RETI -> + let ticks = ticks_of_instruction (ASM.RealInstruction ASM.RETI) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.NOP -> + let ticks = ticks_of_instruction (ASM.RealInstruction ASM.NOP) in + { Types.fst = ticks; Types.snd = ticks } + | ASM.JMP x -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S Nat.O)) }) +| ASM.Comment comment -> { Types.fst = Nat.O; Types.snd = Nat.O } +| ASM.Cost cost -> + let ticks = ticks_of_instruction (ASM.RealInstruction ASM.NOP) in + { Types.fst = ticks; Types.snd = ticks } +| ASM.Jmp jmp -> + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let do_a_long = policy ppc in + let lookup_address = sigma (lookup_labels jmp) in + let { Types.fst = sj_possible; Types.snd = disp } = + short_jump_cond pc_plus_jmp_length lookup_address + in + (match Bool.andb sj_possible (Bool.notb do_a_long) with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S Nat.O)) } + | Bool.False -> + let { Types.fst = mj_possible; Types.snd = disp2 } = + absolute_jump_cond pc_plus_jmp_length lookup_address + in + (match Bool.andb mj_possible (Bool.notb do_a_long) with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S + Nat.O)) })) +| ASM.Jnz (x, x0, x1) -> + { Types.fst = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))); Types.snd = (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))) } +| ASM.Call call -> + let pc_plus_jmp_length = + sigma + (Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) ppc + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S Nat.O))) + in + let lookup_address = sigma (lookup_labels call) in + let { Types.fst = mj_possible; Types.snd = disp } = + absolute_jump_cond pc_plus_jmp_length lookup_address + in + let do_a_long = policy ppc in + (match Bool.andb mj_possible (Bool.notb do_a_long) with + | Bool.True -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S Nat.O)) } + | Bool.False -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S Nat.O)) }) +| ASM.Mov (dst, lbl, off) -> + (match dst with + | Types.Inl x -> + { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S (Nat.S Nat.O)) } + | Types.Inr pr -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Registr, + Vector.VEmpty)))))) pr.Types.fst with + | ASM.DIRECT d -> + (fun _ -> { Types.fst = (Nat.S (Nat.S Nat.O)); Types.snd = (Nat.S + (Nat.S Nat.O)) }) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> { Types.fst = (Nat.S Nat.O); Types.snd = (Nat.S Nat.O) }) + | ASM.ACC_A -> + (fun _ -> { Types.fst = (Nat.S Nat.O); Types.snd = (Nat.S Nat.O) }) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + +(** val ticks_of : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (BitVector.word -> BitVector.word) -> (BitVector.word -> Bool.bool) -> + BitVector.word -> (Nat.nat, Nat.nat) Types.prod **) +let ticks_of program addr_of sigma policy ppc = + let { Types.fst = fetched; Types.snd = new_ppc } = + ASM.fetch_pseudo_instruction program.ASM.code ppc + in + ticks_of0 program addr_of sigma policy ppc fetched + diff --git a/extracted/assembly.mli b/extracted/assembly.mli new file mode 100644 index 0000000..d3bfb51 --- /dev/null +++ b/extracted/assembly.mli @@ -0,0 +1,181 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open BitVectorTrie + +open String + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Arithmetic + +open Fetch + +open Status + +type jump_length = +| Short_jump +| Absolute_jump +| Long_jump + +val jump_length_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 + +val jump_length_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 + +val jump_length_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 + +val jump_length_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 + +val jump_length_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 + +val jump_length_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> jump_length -> 'a1 + +val jump_length_inv_rect_Type4 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val jump_length_inv_rect_Type3 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val jump_length_inv_rect_Type2 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val jump_length_inv_rect_Type1 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val jump_length_inv_rect_Type0 : + jump_length -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val jump_length_discr : jump_length -> jump_length -> __ + +val jump_length_jmdiscr : jump_length -> jump_length -> __ + +val short_jump_cond : + BitVector.word -> BitVector.word -> (Bool.bool, BitVector.bitVector) + Types.prod + +val absolute_jump_cond : + BitVector.word -> BitVector.word -> (Bool.bool, BitVector.bitVector) + Types.prod + +val assembly_preinstruction : + ('a1 -> BitVector.byte) -> 'a1 ASM.preinstruction -> Bool.bool + Vector.vector List.list + +val assembly1 : ASM.instruction -> Bool.bool Vector.vector List.list + +val expand_relative_jump_internal : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> ASM.identifier -> BitVector.word -> + (ASM.subaddressing_mode -> ASM.subaddressing_mode ASM.preinstruction) -> + ASM.instruction List.list + +val expand_relative_jump : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> BitVector.word -> ASM.identifier + ASM.preinstruction -> ASM.instruction List.list + +val is_code : AST.region -> Bool.bool + +val expand_pseudo_instruction : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> BitVector.word -> (ASM.identifier -> + (AST.region, BitVector.word) Types.prod) -> ASM.pseudo_instruction -> + ASM.instruction List.list + +val assembly_1_pseudoinstruction : + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> BitVector.word -> (ASM.identifier -> + (AST.region, BitVector.word) Types.prod) -> ASM.pseudo_instruction -> + (Nat.nat, Bool.bool Vector.vector List.list) Types.prod + +val instruction_size : + (ASM.identifier -> BitVector.word) -> (ASM.identifier -> (AST.region, + BitVector.word) Types.prod) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> BitVector.word -> ASM.pseudo_instruction + -> Nat.nat + +val assembly : + ASM.pseudo_assembly_program -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> ASM.labelled_object_code Types.sig0 + +val ticks_of_instruction : ASM.instruction -> Nat.nat + +val ticks_of0 : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (BitVector.word -> BitVector.word) -> (BitVector.word -> Bool.bool) -> + BitVector.word -> ASM.pseudo_instruction -> (Nat.nat, Nat.nat) Types.prod + +val ticks_of : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (BitVector.word -> BitVector.word) -> (BitVector.word -> Bool.bool) -> + BitVector.word -> (Nat.nat, Nat.nat) Types.prod + diff --git a/extracted/assocList.ml b/extracted/assocList.ml new file mode 100644 index 0000000..9bfcf0d --- /dev/null +++ b/extracted/assocList.ml @@ -0,0 +1,46 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +type ('a, 'b) assoc_list = ('a, 'b) Types.prod List.list + +(** val assoc_list_add : + ('a1, 'a2) Types.prod -> ('a1, 'a2) assoc_list -> ('a1, 'a2) Types.prod + List.list **) +let assoc_list_add el al = + List.Cons (el, al) + +(** val assoc_list_exists : + 'a1 -> ('a1 -> 'a1 -> Bool.bool) -> ('a1, 'a2) Types.prod List.list -> + Bool.bool **) +let rec assoc_list_exists a eq = function +| List.Nil -> Bool.False +| List.Cons (hd, tl) -> + Bool.orb (eq hd.Types.fst a) (assoc_list_exists a eq tl) + +(** val assoc_list_lookup : + 'a1 -> ('a1 -> 'a1 -> Bool.bool) -> ('a1, 'a2) Types.prod List.list -> + 'a2 Types.option **) +let rec assoc_list_lookup a eq = function +| List.Nil -> Types.None +| List.Cons (hd, tl) -> + (match eq hd.Types.fst a with + | Bool.True -> Types.Some hd.Types.snd + | Bool.False -> assoc_list_lookup a eq tl) + diff --git a/extracted/assocList.mli b/extracted/assocList.mli new file mode 100644 index 0000000..27d4b40 --- /dev/null +++ b/extracted/assocList.mli @@ -0,0 +1,34 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +type ('a, 'b) assoc_list = ('a, 'b) Types.prod List.list + +val assoc_list_add : + ('a1, 'a2) Types.prod -> ('a1, 'a2) assoc_list -> ('a1, 'a2) Types.prod + List.list + +val assoc_list_exists : + 'a1 -> ('a1 -> 'a1 -> Bool.bool) -> ('a1, 'a2) Types.prod List.list -> + Bool.bool + +val assoc_list_lookup : + 'a1 -> ('a1 -> 'a1 -> Bool.bool) -> ('a1, 'a2) Types.prod List.list -> 'a2 + Types.option + diff --git a/extracted/bEMem.ml b/extracted/bEMem.ml new file mode 100644 index 0000000..8f6ab81 --- /dev/null +++ b/extracted/bEMem.ml @@ -0,0 +1,98 @@ +open Preamble + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open GenMem + +type bemem = GenMem.mem + +(** val is_addressable : AST.region -> Bool.bool **) +let is_addressable = function +| AST.XData -> Bool.True +| AST.Code -> Bool.True + +type address = (ByteValues.beval, ByteValues.beval) Types.prod + +(** val pointer_of_address : address -> Pointers.pointer Errors.res **) +let pointer_of_address p = + let { Types.fst = v1; Types.snd = v2 } = p in + ByteValues.pointer_of_bevals (List.Cons (v1, (List.Cons (v2, List.Nil)))) + diff --git a/extracted/bEMem.mli b/extracted/bEMem.mli new file mode 100644 index 0000000..79e6142 --- /dev/null +++ b/extracted/bEMem.mli @@ -0,0 +1,92 @@ +open Preamble + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open GenMem + +type bemem = GenMem.mem + +val is_addressable : AST.region -> Bool.bool + +type address = (ByteValues.beval, ByteValues.beval) Types.prod + +val pointer_of_address : address -> Pointers.pointer Errors.res + diff --git a/extracted/backEndOps.ml b/extracted/backEndOps.ml new file mode 100644 index 0000000..9a742b5 --- /dev/null +++ b/extracted/backEndOps.ml @@ -0,0 +1,1225 @@ +open Preamble + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +(** val divmodZ : Z.z -> Z.z -> (Z.z, Z.z) Types.prod **) +let divmodZ x y = + match x with + | Z.OZ -> { Types.fst = Z.OZ; Types.snd = Z.OZ } + | Z.Pos n -> + (match y with + | Z.OZ -> { Types.fst = Z.OZ; Types.snd = Z.OZ } + | Z.Pos m -> + let { Types.fst = q; Types.snd = r } = Division.divide n m in + { Types.fst = (Division.natp_to_Z q); Types.snd = + (Division.natp_to_Z r) } + | Z.Neg m -> + let { Types.fst = q; Types.snd = r } = Division.divide n m in + (match r with + | Division.Pzero -> + { Types.fst = (Division.natp_to_negZ q); Types.snd = Z.OZ } + | Division.Ppos x0 -> + { Types.fst = (Z.zpred (Division.natp_to_negZ q)); Types.snd = + (Z.zplus y (Division.natp_to_Z r)) })) + | Z.Neg n -> + (match y with + | Z.OZ -> { Types.fst = Z.OZ; Types.snd = Z.OZ } + | Z.Pos m -> + let { Types.fst = q; Types.snd = r } = Division.divide n m in + (match r with + | Division.Pzero -> + { Types.fst = (Division.natp_to_negZ q); Types.snd = Z.OZ } + | Division.Ppos x0 -> + { Types.fst = (Z.zpred (Division.natp_to_negZ q)); Types.snd = + (Z.zminus y (Division.natp_to_Z r)) }) + | Z.Neg m -> + let { Types.fst = q; Types.snd = r } = Division.divide n m in + { Types.fst = (Division.natp_to_Z q); Types.snd = + (Division.natp_to_Z r) }) + +type opAccs = +| Mul +| DivuModu + +(** val opAccs_rect_Type4 : 'a1 -> 'a1 -> opAccs -> 'a1 **) +let rec opAccs_rect_Type4 h_Mul h_DivuModu = function +| Mul -> h_Mul +| DivuModu -> h_DivuModu + +(** val opAccs_rect_Type5 : 'a1 -> 'a1 -> opAccs -> 'a1 **) +let rec opAccs_rect_Type5 h_Mul h_DivuModu = function +| Mul -> h_Mul +| DivuModu -> h_DivuModu + +(** val opAccs_rect_Type3 : 'a1 -> 'a1 -> opAccs -> 'a1 **) +let rec opAccs_rect_Type3 h_Mul h_DivuModu = function +| Mul -> h_Mul +| DivuModu -> h_DivuModu + +(** val opAccs_rect_Type2 : 'a1 -> 'a1 -> opAccs -> 'a1 **) +let rec opAccs_rect_Type2 h_Mul h_DivuModu = function +| Mul -> h_Mul +| DivuModu -> h_DivuModu + +(** val opAccs_rect_Type1 : 'a1 -> 'a1 -> opAccs -> 'a1 **) +let rec opAccs_rect_Type1 h_Mul h_DivuModu = function +| Mul -> h_Mul +| DivuModu -> h_DivuModu + +(** val opAccs_rect_Type0 : 'a1 -> 'a1 -> opAccs -> 'a1 **) +let rec opAccs_rect_Type0 h_Mul h_DivuModu = function +| Mul -> h_Mul +| DivuModu -> h_DivuModu + +(** val opAccs_inv_rect_Type4 : + opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let opAccs_inv_rect_Type4 hterm h1 h2 = + let hcut = opAccs_rect_Type4 h1 h2 hterm in hcut __ + +(** val opAccs_inv_rect_Type3 : + opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let opAccs_inv_rect_Type3 hterm h1 h2 = + let hcut = opAccs_rect_Type3 h1 h2 hterm in hcut __ + +(** val opAccs_inv_rect_Type2 : + opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let opAccs_inv_rect_Type2 hterm h1 h2 = + let hcut = opAccs_rect_Type2 h1 h2 hterm in hcut __ + +(** val opAccs_inv_rect_Type1 : + opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let opAccs_inv_rect_Type1 hterm h1 h2 = + let hcut = opAccs_rect_Type1 h1 h2 hterm in hcut __ + +(** val opAccs_inv_rect_Type0 : + opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let opAccs_inv_rect_Type0 hterm h1 h2 = + let hcut = opAccs_rect_Type0 h1 h2 hterm in hcut __ + +(** val opAccs_discr : opAccs -> opAccs -> __ **) +let opAccs_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Mul -> Obj.magic (fun _ dH -> dH) + | DivuModu -> Obj.magic (fun _ dH -> dH)) y + +(** val opAccs_jmdiscr : opAccs -> opAccs -> __ **) +let opAccs_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Mul -> Obj.magic (fun _ dH -> dH) + | DivuModu -> Obj.magic (fun _ dH -> dH)) y + +type op1 = +| Cmpl +| Inc +| Rl + +(** val op1_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 **) +let rec op1_rect_Type4 h_Cmpl h_Inc h_Rl = function +| Cmpl -> h_Cmpl +| Inc -> h_Inc +| Rl -> h_Rl + +(** val op1_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 **) +let rec op1_rect_Type5 h_Cmpl h_Inc h_Rl = function +| Cmpl -> h_Cmpl +| Inc -> h_Inc +| Rl -> h_Rl + +(** val op1_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 **) +let rec op1_rect_Type3 h_Cmpl h_Inc h_Rl = function +| Cmpl -> h_Cmpl +| Inc -> h_Inc +| Rl -> h_Rl + +(** val op1_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 **) +let rec op1_rect_Type2 h_Cmpl h_Inc h_Rl = function +| Cmpl -> h_Cmpl +| Inc -> h_Inc +| Rl -> h_Rl + +(** val op1_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 **) +let rec op1_rect_Type1 h_Cmpl h_Inc h_Rl = function +| Cmpl -> h_Cmpl +| Inc -> h_Inc +| Rl -> h_Rl + +(** val op1_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 **) +let rec op1_rect_Type0 h_Cmpl h_Inc h_Rl = function +| Cmpl -> h_Cmpl +| Inc -> h_Inc +| Rl -> h_Rl + +(** val op1_inv_rect_Type4 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let op1_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = op1_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val op1_inv_rect_Type3 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let op1_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = op1_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val op1_inv_rect_Type2 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let op1_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = op1_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val op1_inv_rect_Type1 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let op1_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = op1_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val op1_inv_rect_Type0 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let op1_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = op1_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val op1_discr : op1 -> op1 -> __ **) +let op1_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Cmpl -> Obj.magic (fun _ dH -> dH) + | Inc -> Obj.magic (fun _ dH -> dH) + | Rl -> Obj.magic (fun _ dH -> dH)) y + +(** val op1_jmdiscr : op1 -> op1 -> __ **) +let op1_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Cmpl -> Obj.magic (fun _ dH -> dH) + | Inc -> Obj.magic (fun _ dH -> dH) + | Rl -> Obj.magic (fun _ dH -> dH)) y + +type op2 = +| Add +| Addc +| Sub +| And +| Or +| Xor + +(** val op2_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 **) +let rec op2_rect_Type4 h_Add h_Addc h_Sub h_And h_Or h_Xor = function +| Add -> h_Add +| Addc -> h_Addc +| Sub -> h_Sub +| And -> h_And +| Or -> h_Or +| Xor -> h_Xor + +(** val op2_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 **) +let rec op2_rect_Type5 h_Add h_Addc h_Sub h_And h_Or h_Xor = function +| Add -> h_Add +| Addc -> h_Addc +| Sub -> h_Sub +| And -> h_And +| Or -> h_Or +| Xor -> h_Xor + +(** val op2_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 **) +let rec op2_rect_Type3 h_Add h_Addc h_Sub h_And h_Or h_Xor = function +| Add -> h_Add +| Addc -> h_Addc +| Sub -> h_Sub +| And -> h_And +| Or -> h_Or +| Xor -> h_Xor + +(** val op2_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 **) +let rec op2_rect_Type2 h_Add h_Addc h_Sub h_And h_Or h_Xor = function +| Add -> h_Add +| Addc -> h_Addc +| Sub -> h_Sub +| And -> h_And +| Or -> h_Or +| Xor -> h_Xor + +(** val op2_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 **) +let rec op2_rect_Type1 h_Add h_Addc h_Sub h_And h_Or h_Xor = function +| Add -> h_Add +| Addc -> h_Addc +| Sub -> h_Sub +| And -> h_And +| Or -> h_Or +| Xor -> h_Xor + +(** val op2_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 **) +let rec op2_rect_Type0 h_Add h_Addc h_Sub h_And h_Or h_Xor = function +| Add -> h_Add +| Addc -> h_Addc +| Sub -> h_Sub +| And -> h_And +| Or -> h_Or +| Xor -> h_Xor + +(** val op2_inv_rect_Type4 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let op2_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = op2_rect_Type4 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val op2_inv_rect_Type3 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let op2_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 = + let hcut = op2_rect_Type3 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val op2_inv_rect_Type2 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let op2_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 = + let hcut = op2_rect_Type2 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val op2_inv_rect_Type1 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let op2_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 = + let hcut = op2_rect_Type1 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val op2_inv_rect_Type0 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 **) +let op2_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 = + let hcut = op2_rect_Type0 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val op2_discr : op2 -> op2 -> __ **) +let op2_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Add -> Obj.magic (fun _ dH -> dH) + | Addc -> Obj.magic (fun _ dH -> dH) + | Sub -> Obj.magic (fun _ dH -> dH) + | And -> Obj.magic (fun _ dH -> dH) + | Or -> Obj.magic (fun _ dH -> dH) + | Xor -> Obj.magic (fun _ dH -> dH)) y + +(** val op2_jmdiscr : op2 -> op2 -> __ **) +let op2_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Add -> Obj.magic (fun _ dH -> dH) + | Addc -> Obj.magic (fun _ dH -> dH) + | Sub -> Obj.magic (fun _ dH -> dH) + | And -> Obj.magic (fun _ dH -> dH) + | Or -> Obj.magic (fun _ dH -> dH) + | Xor -> Obj.magic (fun _ dH -> dH)) y + +type eval = { opaccs : (opAccs -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.byte) Types.prod); + op0 : (op1 -> BitVector.byte -> BitVector.byte); + op3 : (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte + -> (BitVector.byte, BitVector.bit) Types.prod) } + +(** val eval_rect_Type4 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 **) +let rec eval_rect_Type4 h_mk_Eval x_16308 = + let { opaccs = opaccs0; op0 = op4; op3 = op5 } = x_16308 in + h_mk_Eval opaccs0 op4 op5 + +(** val eval_rect_Type5 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 **) +let rec eval_rect_Type5 h_mk_Eval x_16310 = + let { opaccs = opaccs0; op0 = op4; op3 = op5 } = x_16310 in + h_mk_Eval opaccs0 op4 op5 + +(** val eval_rect_Type3 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 **) +let rec eval_rect_Type3 h_mk_Eval x_16312 = + let { opaccs = opaccs0; op0 = op4; op3 = op5 } = x_16312 in + h_mk_Eval opaccs0 op4 op5 + +(** val eval_rect_Type2 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 **) +let rec eval_rect_Type2 h_mk_Eval x_16314 = + let { opaccs = opaccs0; op0 = op4; op3 = op5 } = x_16314 in + h_mk_Eval opaccs0 op4 op5 + +(** val eval_rect_Type1 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 **) +let rec eval_rect_Type1 h_mk_Eval x_16316 = + let { opaccs = opaccs0; op0 = op4; op3 = op5 } = x_16316 in + h_mk_Eval opaccs0 op4 op5 + +(** val eval_rect_Type0 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 **) +let rec eval_rect_Type0 h_mk_Eval x_16318 = + let { opaccs = opaccs0; op0 = op4; op3 = op5 } = x_16318 in + h_mk_Eval opaccs0 op4 op5 + +(** val opaccs : + eval -> opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod **) +let rec opaccs xxx = + xxx.opaccs + +(** val op0 : eval -> op1 -> BitVector.byte -> BitVector.byte **) +let rec op0 xxx = + xxx.op0 + +(** val op3 : + eval -> BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod **) +let rec op3 xxx = + xxx.op3 + +(** val eval_inv_rect_Type4 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 **) +let eval_inv_rect_Type4 hterm h1 = + let hcut = eval_rect_Type4 h1 hterm in hcut __ + +(** val eval_inv_rect_Type3 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 **) +let eval_inv_rect_Type3 hterm h1 = + let hcut = eval_rect_Type3 h1 hterm in hcut __ + +(** val eval_inv_rect_Type2 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 **) +let eval_inv_rect_Type2 hterm h1 = + let hcut = eval_rect_Type2 h1 hterm in hcut __ + +(** val eval_inv_rect_Type1 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 **) +let eval_inv_rect_Type1 hterm h1 = + let hcut = eval_rect_Type1 h1 hterm in hcut __ + +(** val eval_inv_rect_Type0 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) + -> (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 **) +let eval_inv_rect_Type0 hterm h1 = + let hcut = eval_rect_Type0 h1 hterm in hcut __ + +(** val eval_discr : eval -> eval -> __ **) +let eval_discr x y = + Logic.eq_rect_Type2 x + (let { opaccs = a0; op0 = a1; op3 = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val eval_jmdiscr : eval -> eval -> __ **) +let eval_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { opaccs = a0; op0 = a1; op3 = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val opaccs_implementation : + opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod **) +let opaccs_implementation op by1 by2 = + let n1 = + BitVectorZ.z_of_unsigned_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) by1 + in + let n2 = + BitVectorZ.z_of_unsigned_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) by2 + in + (match op with + | Mul -> + let prod = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (BitVectorZ.bitvector_of_Z + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Z.z_times n1 n2)) + in + { Types.fst = prod.Types.snd; Types.snd = prod.Types.fst } + | DivuModu -> + (match Z.eqZb n2 Z.OZ with + | Bool.True -> { Types.fst = by1; Types.snd = by2 } + | Bool.False -> + let { Types.fst = q; Types.snd = r } = divmodZ n1 n2 in + { Types.fst = + (BitVectorZ.bitvector_of_Z (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) q); Types.snd = + (BitVectorZ.bitvector_of_Z (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) r) })) + +(** val op1_implementation : op1 -> BitVector.byte -> BitVector.byte **) +let op1_implementation op by = + match op with + | Cmpl -> + BitVector.negation_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) by + | Inc -> + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) by + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + | Rl -> + Vector.rotate_left (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S Nat.O) by + +(** val op2_implementation : + BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod **) +let op2_implementation carry op by1 by2 = + match op with + | Add -> + let { Types.fst = res; Types.snd = flags } = + Arithmetic.add_8_with_carry by1 by2 Bool.False + in + { Types.fst = res; Types.snd = + (Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags) } + | Addc -> + let { Types.fst = res; Types.snd = flags } = + Arithmetic.add_8_with_carry by1 by2 carry + in + { Types.fst = res; Types.snd = + (Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags) } + | Sub -> + let { Types.fst = res; Types.snd = flags } = + Arithmetic.sub_8_with_carry by1 by2 carry + in + { Types.fst = res; Types.snd = + (Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags) } + | And -> + { Types.fst = + (BitVector.conjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) by1 by2); Types.snd = carry } + | Or -> + { Types.fst = + (BitVector.inclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) by1 by2); Types.snd = carry } + | Xor -> + { Types.fst = + (BitVector.exclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) by1 by2); Types.snd = carry } + +(** val eval0 : eval **) +let eval0 = + { opaccs = opaccs_implementation; op0 = op1_implementation; op3 = + op2_implementation } + +(** val be_opaccs : + opAccs -> ByteValues.beval -> ByteValues.beval -> (ByteValues.beval, + ByteValues.beval) Types.prod Errors.res **) +let be_opaccs op a b = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ByteValues.byte_of_val ErrorMessages.UnsupportedOp a)) + (fun a' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ByteValues.byte_of_val ErrorMessages.UnsupportedOp b)) + (fun b' -> + let { Types.fst = a''; Types.snd = b'' } = eval0.opaccs op a' b' in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVByte a''); Types.snd = (ByteValues.BVByte b'') }))) + +(** val be_op1 : op1 -> ByteValues.beval -> ByteValues.beval Errors.res **) +let be_op1 op a = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ByteValues.byte_of_val ErrorMessages.UnsupportedOp a)) + (fun a' -> + Monad.m_return0 (Monad.max_def Errors.res0) (ByteValues.BVByte + (eval0.op0 op a')))) + +(** val op2_bytes : + op2 -> Nat.nat -> BitVector.bit -> BitVector.byte Vector.vector -> + BitVector.byte Vector.vector -> (BitVector.byte Vector.vector, + BitVector.bit) Types.prod **) +let op2_bytes op n carry = + let f = fun n0 b1 b2 pr -> + let { Types.fst = res_tl; Types.snd = carry0 } = pr in + let { Types.fst = res_hd; Types.snd = carry' } = + eval0.op3 carry0 op b1 b2 + in + { Types.fst = (Vector.VCons (n0, res_hd, res_tl)); Types.snd = carry' } + in + Vector.fold_right2_i f { Types.fst = Vector.VEmpty; Types.snd = carry } n + +(** val op_of_add_or_sub : ByteValues.add_or_sub -> op2 **) +let op_of_add_or_sub = function +| ByteValues.Do_add -> Addc +| ByteValues.Do_sub -> Sub + +(** val be_add_sub_byte : + ByteValues.add_or_sub -> ByteValues.bebit -> ByteValues.beval -> + BitVector.byte -> (ByteValues.beval, ByteValues.bebit) Types.prod + Errors.res **) +let be_add_sub_byte is_add carry a1 b2 = + let op = op_of_add_or_sub is_add in + (match a1 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (ByteValues.bit_of_val ErrorMessages.UnsupportedOp carry)) + (fun carry' -> + let { Types.fst = rslt; Types.snd = carry'' } = + eval0.op3 carry' op b1 b2 + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVByte rslt); Types.snd = (ByteValues.BBbit carry'') })) + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (ptr, p) -> + (match Pointers.ptype ptr with + | AST.XData -> + (match ByteValues.part_no p with + | Nat.O -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (ByteValues.bit_of_val ErrorMessages.UnsupportedOp carry)) + (fun carry' -> + match carry' with + | Bool.True -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | Bool.False -> + let o1o0 = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Pointers.offv ptr.Pointers.poff) + in + let { Types.fst = rslt; Types.snd = carry0 } = + eval0.op3 Bool.False op o1o0.Types.snd b2 + in + let p0 = Nat.O in + let ptr' = { Pointers.pblock = ptr.Pointers.pblock; + Pointers.poff = + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) o1o0.Types.fst + rslt) } + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVptr (ptr', p)); Types.snd = + (ByteValues.BBptrcarry (is_add, ptr, p0, b2)) })) + | Nat.S x -> + (match carry with + | ByteValues.BBbit x0 -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil)) + | ByteValues.BBundef -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil)) + | ByteValues.BBptrcarry (is_add', ptr', p', by') -> + (match Bool.andb + (Bool.andb (ByteValues.eq_add_or_sub is_add is_add') + (Pointers.eq_block ptr.Pointers.pblock + ptr'.Pointers.pblock)) + (ByteValues.eq_bv_suffix (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Pointers.offv ptr.Pointers.poff) + (Pointers.offv ptr'.Pointers.poff)) with + | Bool.True -> + Util.if_then_else_safe + (Nat.eqb (ByteValues.part_no p') Nat.O) (fun _ -> + let by'0 = (fun _ _ -> by') __ __ in + let o1o0 = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Pointers.offv ptr.Pointers.poff) + in + let o1o1 = Vector.VCons ((Nat.S Nat.O), o1o0.Types.fst, + (Vector.VCons (Nat.O, o1o0.Types.snd, Vector.VEmpty))) + in + let { Types.fst = rslt; Types.snd = ignore } = + op2_bytes op (Nat.S (Nat.S Nat.O)) Bool.False o1o1 + (Vector.VCons ((Nat.S Nat.O), b2, (Vector.VCons + (Nat.O, by'0, Vector.VEmpty)))) + in + let part1 = Nat.S Nat.O in + let ptr'' = { Pointers.pblock = ptr.Pointers.pblock; + Pointers.poff = + (Vector.vflatten (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) rslt) } + in + Errors.OK { Types.fst = (ByteValues.BVptr (ptr'', part1)); + Types.snd = (ByteValues.BBptrcarry (is_add, ptr', part1, + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) b2 by'0))) }) + (fun _ -> Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))))) + | AST.Code -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + +(** val byte_at : + Nat.nat -> BitVector.bitVector -> Nat.nat -> BitVector.byte **) +let byte_at n v p = + let suffix = + (Vector.vsplit + (Nat.times (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.minus n (Nat.S p))) + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) + (Nat.times (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) p)) v).Types.snd + in + (Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) + (Nat.times (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) p) suffix).Types.fst + +(** val eq_opt : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 Types.option -> 'a1 Types.option -> + Bool.bool **) +let eq_opt eq m n = + match m with + | Types.None -> + (match m with + | Types.None -> Bool.True + | Types.Some x -> Bool.False) + | Types.Some a -> + (match n with + | Types.None -> Bool.False + | Types.Some b -> eq a b) + +(** val be_op2 : + ByteValues.bebit -> op2 -> ByteValues.beval -> ByteValues.beval -> + (ByteValues.beval, ByteValues.bebit) Types.prod Errors.res **) +let be_op2 carry op a1 a2 = + match op with + | Add -> + (match a1 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b1 -> + be_add_sub_byte ByteValues.Do_add (ByteValues.BBbit Bool.False) a2 b1 + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (ptr1, p1) -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b2 -> + be_add_sub_byte ByteValues.Do_add (ByteValues.BBbit Bool.False) a1 + b2 + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | Addc -> + (match a1 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b1 -> be_add_sub_byte ByteValues.Do_add carry a2 b1 + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (ptr1, p1) -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b2 -> + be_add_sub_byte ByteValues.Do_add carry a1 b2 + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | Sub -> + (match a1 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (ByteValues.byte_of_val ErrorMessages.UnsupportedOp a2)) + (fun b2 -> + Obj.magic (be_add_sub_byte ByteValues.Do_sub carry a1 b2))) + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (ptr1, p1) -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b2 -> + be_add_sub_byte ByteValues.Do_sub carry a1 b2 + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (ptr2, p2) -> + (match Pointers.ptype ptr1 with + | AST.XData -> + (match Bool.andb + (Pointers.eq_block ptr1.Pointers.pblock + ptr2.Pointers.pblock) + (Nat.eqb (ByteValues.part_no p1) + (ByteValues.part_no p2)) with + | Bool.True -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (ByteValues.bit_of_val ErrorMessages.UnsupportedOp + carry)) (fun carry0 -> + let by1 = + byte_at AST.size_pointer + (Pointers.offv ptr1.Pointers.poff) + (ByteValues.part_no p1) + in + let by2 = + byte_at AST.size_pointer + (Pointers.offv ptr2.Pointers.poff) + (ByteValues.part_no p1) + in + let { Types.fst = result; Types.snd = carry1 } = + eval0.op3 carry0 Sub by1 by2 + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVByte result); Types.snd = + (ByteValues.BBbit carry1) })) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | AST.Code -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | And -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ByteValues.byte_of_val ErrorMessages.UnsupportedOp a1)) + (fun b1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ByteValues.byte_of_val ErrorMessages.UnsupportedOp a2)) + (fun b2 -> + let res = (eval0.op3 Bool.False And b1 b2).Types.fst in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVByte res); Types.snd = carry }))) + | Or -> + (match a1 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + ByteValues.BVnonzero; Types.snd = carry }) + | ByteValues.BVXor (x, x0, x1) -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + ByteValues.BVnonzero; Types.snd = carry }) + | ByteValues.BVByte x -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + ByteValues.BVnonzero; Types.snd = carry }) + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVXor (ptr1_opt, ptr1_opt', p1) -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + ByteValues.BVnonzero; Types.snd = carry }) + | ByteValues.BVXor (ptr2_opt, ptr2_opt', p2) -> + (match Bool.orb + (Bool.andb (Nat.eqb (ByteValues.part_no p1) Nat.O) + (Nat.eqb (ByteValues.part_no p2) (Nat.S Nat.O))) + (Bool.andb (Nat.eqb (ByteValues.part_no p1) (Nat.S Nat.O)) + (Nat.eqb (ByteValues.part_no p2) Nat.O)) with + | Bool.True -> + let eq_at = fun p ptr1 ptr2 -> + Bool.andb + (Pointers.eq_block ptr1.Pointers.pblock + ptr2.Pointers.pblock) + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (byte_at AST.size_pointer + (Pointers.offv ptr1.Pointers.poff) + (ByteValues.part_no p)) + (byte_at AST.size_pointer + (Pointers.offv ptr2.Pointers.poff) + (ByteValues.part_no p))) + in + (match Bool.andb (eq_opt (eq_at p1) ptr1_opt ptr1_opt') + (eq_opt (eq_at p2) ptr2_opt ptr2_opt') with + | Bool.True -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVByte + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))); Types.snd = carry }) + | Bool.False -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + ByteValues.BVnonzero; Types.snd = carry })) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | ByteValues.BVByte x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVByte b1 -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + ByteValues.BVnonzero; Types.snd = carry }) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b2 -> + let res = (eval0.op3 Bool.False Or b1 b2).Types.fst in + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVByte res); Types.snd = carry }) + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | Xor -> + (match a1 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b1 -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte b2 -> + let res = (eval0.op3 Bool.False Xor b1 b2).Types.fst in + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVByte res); Types.snd = carry }) + | ByteValues.BVnull x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVnull p1 -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnull p2 -> + (match Nat.eqb (ByteValues.part_no p1) (ByteValues.part_no p2) with + | Bool.True -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVXor (Types.None, Types.None, p1)); Types.snd = + carry }) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | ByteValues.BVptr (ptr2, p2) -> + (match Nat.eqb (ByteValues.part_no p1) (ByteValues.part_no p2) with + | Bool.True -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVXor (Types.None, (Types.Some ptr2), p1)); + Types.snd = carry }) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVptr (ptr1, p1) -> + (match a2 with + | ByteValues.BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVByte x -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil)) + | ByteValues.BVnull p2 -> + (match Nat.eqb (ByteValues.part_no p1) (ByteValues.part_no p2) with + | Bool.True -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVXor ((Types.Some ptr1), Types.None, p1)); + Types.snd = carry }) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | ByteValues.BVptr (ptr2, p2) -> + (match Nat.eqb (ByteValues.part_no p1) (ByteValues.part_no p2) with + | Bool.True -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (ByteValues.BVXor ((Types.Some ptr1), (Types.Some ptr2), + p1)); Types.snd = carry }) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.UnsupportedOp), List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + | ByteValues.BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnsupportedOp), + List.Nil))) + diff --git a/extracted/backEndOps.mli b/extracted/backEndOps.mli new file mode 100644 index 0000000..1a53f25 --- /dev/null +++ b/extracted/backEndOps.mli @@ -0,0 +1,320 @@ +open Preamble + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +val divmodZ : Z.z -> Z.z -> (Z.z, Z.z) Types.prod + +type opAccs = +| Mul +| DivuModu + +val opAccs_rect_Type4 : 'a1 -> 'a1 -> opAccs -> 'a1 + +val opAccs_rect_Type5 : 'a1 -> 'a1 -> opAccs -> 'a1 + +val opAccs_rect_Type3 : 'a1 -> 'a1 -> opAccs -> 'a1 + +val opAccs_rect_Type2 : 'a1 -> 'a1 -> opAccs -> 'a1 + +val opAccs_rect_Type1 : 'a1 -> 'a1 -> opAccs -> 'a1 + +val opAccs_rect_Type0 : 'a1 -> 'a1 -> opAccs -> 'a1 + +val opAccs_inv_rect_Type4 : opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val opAccs_inv_rect_Type3 : opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val opAccs_inv_rect_Type2 : opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val opAccs_inv_rect_Type1 : opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val opAccs_inv_rect_Type0 : opAccs -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val opAccs_discr : opAccs -> opAccs -> __ + +val opAccs_jmdiscr : opAccs -> opAccs -> __ + +type op1 = +| Cmpl +| Inc +| Rl + +val op1_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 + +val op1_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 + +val op1_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 + +val op1_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 + +val op1_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 + +val op1_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> op1 -> 'a1 + +val op1_inv_rect_Type4 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val op1_inv_rect_Type3 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val op1_inv_rect_Type2 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val op1_inv_rect_Type1 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val op1_inv_rect_Type0 : + op1 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val op1_discr : op1 -> op1 -> __ + +val op1_jmdiscr : op1 -> op1 -> __ + +type op2 = +| Add +| Addc +| Sub +| And +| Or +| Xor + +val op2_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 + +val op2_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 + +val op2_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 + +val op2_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 + +val op2_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 + +val op2_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> op2 -> 'a1 + +val op2_inv_rect_Type4 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 + +val op2_inv_rect_Type3 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 + +val op2_inv_rect_Type2 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 + +val op2_inv_rect_Type1 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 + +val op2_inv_rect_Type0 : + op2 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> 'a1 + +val op2_discr : op2 -> op2 -> __ + +val op2_jmdiscr : op2 -> op2 -> __ + +type eval = { opaccs : (opAccs -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.byte) Types.prod); + op0 : (op1 -> BitVector.byte -> BitVector.byte); + op3 : (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte + -> (BitVector.byte, BitVector.bit) Types.prod) } + +val eval_rect_Type4 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 + +val eval_rect_Type5 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 + +val eval_rect_Type3 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 + +val eval_rect_Type2 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 + +val eval_rect_Type1 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 + +val eval_rect_Type0 : + ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> 'a1) -> eval -> 'a1 + +val opaccs : + eval -> opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod + +val op0 : eval -> op1 -> BitVector.byte -> BitVector.byte + +val op3 : + eval -> BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod + +val eval_inv_rect_Type4 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 + +val eval_inv_rect_Type3 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 + +val eval_inv_rect_Type2 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 + +val eval_inv_rect_Type1 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 + +val eval_inv_rect_Type0 : + eval -> ((opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod) -> (op1 -> BitVector.byte -> BitVector.byte) -> + (BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod) -> __ -> 'a1) -> 'a1 + +val eval_discr : eval -> eval -> __ + +val eval_jmdiscr : eval -> eval -> __ + +val opaccs_implementation : + opAccs -> BitVector.byte -> BitVector.byte -> (BitVector.byte, + BitVector.byte) Types.prod + +val op1_implementation : op1 -> BitVector.byte -> BitVector.byte + +val op2_implementation : + BitVector.bit -> op2 -> BitVector.byte -> BitVector.byte -> + (BitVector.byte, BitVector.bit) Types.prod + +val eval0 : eval + +val be_opaccs : + opAccs -> ByteValues.beval -> ByteValues.beval -> (ByteValues.beval, + ByteValues.beval) Types.prod Errors.res + +val be_op1 : op1 -> ByteValues.beval -> ByteValues.beval Errors.res + +val op2_bytes : + op2 -> Nat.nat -> BitVector.bit -> BitVector.byte Vector.vector -> + BitVector.byte Vector.vector -> (BitVector.byte Vector.vector, + BitVector.bit) Types.prod + +val op_of_add_or_sub : ByteValues.add_or_sub -> op2 + +val be_add_sub_byte : + ByteValues.add_or_sub -> ByteValues.bebit -> ByteValues.beval -> + BitVector.byte -> (ByteValues.beval, ByteValues.bebit) Types.prod + Errors.res + +val byte_at : Nat.nat -> BitVector.bitVector -> Nat.nat -> BitVector.byte + +val eq_opt : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 Types.option -> 'a1 Types.option -> + Bool.bool + +val be_op2 : + ByteValues.bebit -> op2 -> ByteValues.beval -> ByteValues.beval -> + (ByteValues.beval, ByteValues.bebit) Types.prod Errors.res + diff --git a/extracted/bigops.ml b/extracted/bigops.ml new file mode 100644 index 0000000..c2f9cd0 --- /dev/null +++ b/extracted/bigops.ml @@ -0,0 +1,371 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Div_and_mod + +(** val prodF : + (Nat.nat -> 'a1) -> (Nat.nat -> 'a2) -> Nat.nat -> Nat.nat -> ('a1, 'a2) + Types.prod **) +let prodF f g m x = + { Types.fst = (f (Div_and_mod.div x m)); Types.snd = + (g (Div_and_mod.mod0 x m)) } + +(** val bigop : + Nat.nat -> (Nat.nat -> Bool.bool) -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> + (Nat.nat -> 'a1) -> 'a1 **) +let rec bigop n p nil op f = + match n with + | Nat.O -> nil + | Nat.S k -> + (match p k with + | Bool.True -> op (f k) (bigop k p nil op f) + | Bool.False -> bigop k p nil op f) + +type 'a aop = + 'a -> 'a -> 'a + (* singleton inductive, whose constructor was mk_Aop *) + +(** val aop_rect_Type4 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type4 nil h_mk_Aop x_969 = + let op = x_969 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type5 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type5 nil h_mk_Aop x_971 = + let op = x_971 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type3 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type3 nil h_mk_Aop x_973 = + let op = x_973 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type2 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type2 nil h_mk_Aop x_975 = + let op = x_975 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type1 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type1 nil h_mk_Aop x_977 = + let op = x_977 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type0 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type0 nil h_mk_Aop x_979 = + let op = x_979 in h_mk_Aop op __ __ __ + +(** val op : 'a1 -> 'a1 aop -> 'a1 -> 'a1 -> 'a1 **) +let rec op nil xxx = + let yyy = xxx in yyy + +(** val aop_inv_rect_Type4 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type4 x2 hterm h1 = + let hcut = aop_rect_Type4 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type3 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type3 x2 hterm h1 = + let hcut = aop_rect_Type3 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type2 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type2 x2 hterm h1 = + let hcut = aop_rect_Type2 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type1 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type1 x2 hterm h1 = + let hcut = aop_rect_Type1 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type0 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type0 x2 hterm h1 = + let hcut = aop_rect_Type0 x2 h1 hterm in hcut __ + +(** val aop_discr : 'a1 -> 'a1 aop -> 'a1 aop -> __ **) +let aop_discr a2 x y = + Logic.eq_rect_Type2 x + (let a0 = x in Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val dpi1__o__op : + 'a1 -> ('a1 aop, 'a2) Types.dPair -> 'a1 -> 'a1 -> 'a1 **) +let dpi1__o__op x1 x3 = + op x1 x3.Types.dpi1 + +type 'a aCop = + 'a aop + (* singleton inductive, whose constructor was mk_ACop *) + +(** val aCop_rect_Type4 : + 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 **) +let rec aCop_rect_Type4 nil h_mk_ACop x_997 = + let aop0 = x_997 in h_mk_ACop aop0 __ + +(** val aCop_rect_Type5 : + 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 **) +let rec aCop_rect_Type5 nil h_mk_ACop x_999 = + let aop0 = x_999 in h_mk_ACop aop0 __ + +(** val aCop_rect_Type3 : + 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 **) +let rec aCop_rect_Type3 nil h_mk_ACop x_1001 = + let aop0 = x_1001 in h_mk_ACop aop0 __ + +(** val aCop_rect_Type2 : + 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 **) +let rec aCop_rect_Type2 nil h_mk_ACop x_1003 = + let aop0 = x_1003 in h_mk_ACop aop0 __ + +(** val aCop_rect_Type1 : + 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 **) +let rec aCop_rect_Type1 nil h_mk_ACop x_1005 = + let aop0 = x_1005 in h_mk_ACop aop0 __ + +(** val aCop_rect_Type0 : + 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 **) +let rec aCop_rect_Type0 nil h_mk_ACop x_1007 = + let aop0 = x_1007 in h_mk_ACop aop0 __ + +(** val aop0 : 'a1 -> 'a1 aCop -> 'a1 aop **) +let rec aop0 nil xxx = + let yyy = xxx in yyy + +(** val aCop_inv_rect_Type4 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 **) +let aCop_inv_rect_Type4 x2 hterm h1 = + let hcut = aCop_rect_Type4 x2 h1 hterm in hcut __ + +(** val aCop_inv_rect_Type3 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 **) +let aCop_inv_rect_Type3 x2 hterm h1 = + let hcut = aCop_rect_Type3 x2 h1 hterm in hcut __ + +(** val aCop_inv_rect_Type2 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 **) +let aCop_inv_rect_Type2 x2 hterm h1 = + let hcut = aCop_rect_Type2 x2 h1 hterm in hcut __ + +(** val aCop_inv_rect_Type1 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 **) +let aCop_inv_rect_Type1 x2 hterm h1 = + let hcut = aCop_rect_Type1 x2 h1 hterm in hcut __ + +(** val aCop_inv_rect_Type0 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 **) +let aCop_inv_rect_Type0 x2 hterm h1 = + let hcut = aCop_rect_Type0 x2 h1 hterm in hcut __ + +(** val aCop_discr : 'a1 -> 'a1 aCop -> 'a1 aCop -> __ **) +let aCop_discr a2 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val dpi1__o__aop__o__op : + 'a1 -> ('a1 aCop, 'a2) Types.dPair -> 'a1 -> 'a1 -> 'a1 **) +let dpi1__o__aop__o__op x1 x3 = + op x1 (aop0 x1 x3.Types.dpi1) + +(** val aop__o__op : 'a1 -> 'a1 aCop -> 'a1 -> 'a1 -> 'a1 **) +let aop__o__op x1 x2 = + op x1 (aop0 x1 x2) + +(** val dpi1__o__aop : 'a1 -> ('a1 aCop, 'a2) Types.dPair -> 'a1 aop **) +let dpi1__o__aop x1 x3 = + aop0 x1 x3.Types.dpi1 + +type 'a range = { enum : (Nat.nat -> 'a); upto : Nat.nat; + filter : (Nat.nat -> Bool.bool) } + +(** val range_rect_Type4 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 + range -> 'a2 **) +let rec range_rect_Type4 h_mk_range x_1023 = + let { enum = enum0; upto = upto0; filter = filter0 } = x_1023 in + h_mk_range enum0 upto0 filter0 + +(** val range_rect_Type5 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 + range -> 'a2 **) +let rec range_rect_Type5 h_mk_range x_1025 = + let { enum = enum0; upto = upto0; filter = filter0 } = x_1025 in + h_mk_range enum0 upto0 filter0 + +(** val range_rect_Type3 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 + range -> 'a2 **) +let rec range_rect_Type3 h_mk_range x_1027 = + let { enum = enum0; upto = upto0; filter = filter0 } = x_1027 in + h_mk_range enum0 upto0 filter0 + +(** val range_rect_Type2 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 + range -> 'a2 **) +let rec range_rect_Type2 h_mk_range x_1029 = + let { enum = enum0; upto = upto0; filter = filter0 } = x_1029 in + h_mk_range enum0 upto0 filter0 + +(** val range_rect_Type1 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 + range -> 'a2 **) +let rec range_rect_Type1 h_mk_range x_1031 = + let { enum = enum0; upto = upto0; filter = filter0 } = x_1031 in + h_mk_range enum0 upto0 filter0 + +(** val range_rect_Type0 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 + range -> 'a2 **) +let rec range_rect_Type0 h_mk_range x_1033 = + let { enum = enum0; upto = upto0; filter = filter0 } = x_1033 in + h_mk_range enum0 upto0 filter0 + +(** val enum : 'a1 range -> Nat.nat -> 'a1 **) +let rec enum xxx = + xxx.enum + +(** val upto : 'a1 range -> Nat.nat **) +let rec upto xxx = + xxx.upto + +(** val filter : 'a1 range -> Nat.nat -> Bool.bool **) +let rec filter xxx = + xxx.filter + +(** val range_inv_rect_Type4 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 **) +let range_inv_rect_Type4 hterm h1 = + let hcut = range_rect_Type4 h1 hterm in hcut __ + +(** val range_inv_rect_Type3 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 **) +let range_inv_rect_Type3 hterm h1 = + let hcut = range_rect_Type3 h1 hterm in hcut __ + +(** val range_inv_rect_Type2 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 **) +let range_inv_rect_Type2 hterm h1 = + let hcut = range_rect_Type2 h1 hterm in hcut __ + +(** val range_inv_rect_Type1 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 **) +let range_inv_rect_Type1 hterm h1 = + let hcut = range_rect_Type1 h1 hterm in hcut __ + +(** val range_inv_rect_Type0 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 **) +let range_inv_rect_Type0 hterm h1 = + let hcut = range_rect_Type0 h1 hterm in hcut __ + +(** val range_discr : 'a1 range -> 'a1 range -> __ **) +let range_discr x y = + Logic.eq_rect_Type2 x + (let { enum = a0; upto = a10; filter = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +type 'a dop = { sum0 : 'a aCop; prod0 : ('a -> 'a -> 'a) } + +(** val dop_rect_Type4 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 **) +let rec dop_rect_Type4 nil h_mk_Dop x_1051 = + let { sum0 = sum1; prod0 = prod1 } = x_1051 in h_mk_Dop sum1 prod1 __ __ + +(** val dop_rect_Type5 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 **) +let rec dop_rect_Type5 nil h_mk_Dop x_1053 = + let { sum0 = sum1; prod0 = prod1 } = x_1053 in h_mk_Dop sum1 prod1 __ __ + +(** val dop_rect_Type3 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 **) +let rec dop_rect_Type3 nil h_mk_Dop x_1055 = + let { sum0 = sum1; prod0 = prod1 } = x_1055 in h_mk_Dop sum1 prod1 __ __ + +(** val dop_rect_Type2 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 **) +let rec dop_rect_Type2 nil h_mk_Dop x_1057 = + let { sum0 = sum1; prod0 = prod1 } = x_1057 in h_mk_Dop sum1 prod1 __ __ + +(** val dop_rect_Type1 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 **) +let rec dop_rect_Type1 nil h_mk_Dop x_1059 = + let { sum0 = sum1; prod0 = prod1 } = x_1059 in h_mk_Dop sum1 prod1 __ __ + +(** val dop_rect_Type0 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 **) +let rec dop_rect_Type0 nil h_mk_Dop x_1061 = + let { sum0 = sum1; prod0 = prod1 } = x_1061 in h_mk_Dop sum1 prod1 __ __ + +(** val sum0 : 'a1 -> 'a1 dop -> 'a1 aCop **) +let rec sum0 nil xxx = + xxx.sum0 + +(** val prod0 : 'a1 -> 'a1 dop -> 'a1 -> 'a1 -> 'a1 **) +let rec prod0 nil xxx = + xxx.prod0 + +(** val dop_inv_rect_Type4 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 **) +let dop_inv_rect_Type4 x2 hterm h1 = + let hcut = dop_rect_Type4 x2 h1 hterm in hcut __ + +(** val dop_inv_rect_Type3 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 **) +let dop_inv_rect_Type3 x2 hterm h1 = + let hcut = dop_rect_Type3 x2 h1 hterm in hcut __ + +(** val dop_inv_rect_Type2 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 **) +let dop_inv_rect_Type2 x2 hterm h1 = + let hcut = dop_rect_Type2 x2 h1 hterm in hcut __ + +(** val dop_inv_rect_Type1 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 **) +let dop_inv_rect_Type1 x2 hterm h1 = + let hcut = dop_rect_Type1 x2 h1 hterm in hcut __ + +(** val dop_inv_rect_Type0 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 **) +let dop_inv_rect_Type0 x2 hterm h1 = + let hcut = dop_rect_Type0 x2 h1 hterm in hcut __ + +(** val dop_discr : 'a1 -> 'a1 dop -> 'a1 dop -> __ **) +let dop_discr a2 x y = + Logic.eq_rect_Type2 x + (let { sum0 = a0; prod0 = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + diff --git a/extracted/bigops.mli b/extracted/bigops.mli new file mode 100644 index 0000000..d122737 --- /dev/null +++ b/extracted/bigops.mli @@ -0,0 +1,225 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Div_and_mod + +val prodF : + (Nat.nat -> 'a1) -> (Nat.nat -> 'a2) -> Nat.nat -> Nat.nat -> ('a1, 'a2) + Types.prod + +val bigop : + Nat.nat -> (Nat.nat -> Bool.bool) -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> (Nat.nat + -> 'a1) -> 'a1 + +type 'a aop = + 'a -> 'a -> 'a + (* singleton inductive, whose constructor was mk_Aop *) + +val aop_rect_Type4 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type5 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type3 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type2 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type1 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type0 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val op : 'a1 -> 'a1 aop -> 'a1 -> 'a1 -> 'a1 + +val aop_inv_rect_Type4 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type3 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type2 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type1 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type0 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_discr : 'a1 -> 'a1 aop -> 'a1 aop -> __ + +val dpi1__o__op : 'a1 -> ('a1 aop, 'a2) Types.dPair -> 'a1 -> 'a1 -> 'a1 + +type 'a aCop = + 'a aop + (* singleton inductive, whose constructor was mk_ACop *) + +val aCop_rect_Type4 : 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 + +val aCop_rect_Type5 : 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 + +val aCop_rect_Type3 : 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 + +val aCop_rect_Type2 : 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 + +val aCop_rect_Type1 : 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 + +val aCop_rect_Type0 : 'a1 -> ('a1 aop -> __ -> 'a2) -> 'a1 aCop -> 'a2 + +val aop0 : 'a1 -> 'a1 aCop -> 'a1 aop + +val aCop_inv_rect_Type4 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 + +val aCop_inv_rect_Type3 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 + +val aCop_inv_rect_Type2 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 + +val aCop_inv_rect_Type1 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 + +val aCop_inv_rect_Type0 : + 'a1 -> 'a1 aCop -> ('a1 aop -> __ -> __ -> 'a2) -> 'a2 + +val aCop_discr : 'a1 -> 'a1 aCop -> 'a1 aCop -> __ + +val dpi1__o__aop__o__op : + 'a1 -> ('a1 aCop, 'a2) Types.dPair -> 'a1 -> 'a1 -> 'a1 + +val aop__o__op : 'a1 -> 'a1 aCop -> 'a1 -> 'a1 -> 'a1 + +val dpi1__o__aop : 'a1 -> ('a1 aCop, 'a2) Types.dPair -> 'a1 aop + +type 'a range = { enum : (Nat.nat -> 'a); upto : Nat.nat; + filter : (Nat.nat -> Bool.bool) } + +val range_rect_Type4 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 range + -> 'a2 + +val range_rect_Type5 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 range + -> 'a2 + +val range_rect_Type3 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 range + -> 'a2 + +val range_rect_Type2 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 range + -> 'a2 + +val range_rect_Type1 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 range + -> 'a2 + +val range_rect_Type0 : + ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> 'a2) -> 'a1 range + -> 'a2 + +val enum : 'a1 range -> Nat.nat -> 'a1 + +val upto : 'a1 range -> Nat.nat + +val filter : 'a1 range -> Nat.nat -> Bool.bool + +val range_inv_rect_Type4 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 + +val range_inv_rect_Type3 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 + +val range_inv_rect_Type2 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 + +val range_inv_rect_Type1 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 + +val range_inv_rect_Type0 : + 'a1 range -> ((Nat.nat -> 'a1) -> Nat.nat -> (Nat.nat -> Bool.bool) -> __ + -> 'a2) -> 'a2 + +val range_discr : 'a1 range -> 'a1 range -> __ + +type 'a dop = { sum0 : 'a aCop; prod0 : ('a -> 'a -> 'a) } + +val dop_rect_Type4 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 + +val dop_rect_Type5 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 + +val dop_rect_Type3 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 + +val dop_rect_Type2 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 + +val dop_rect_Type1 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 + +val dop_rect_Type0 : + 'a1 -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> 'a2) -> 'a1 dop -> + 'a2 + +val sum0 : 'a1 -> 'a1 dop -> 'a1 aCop + +val prod0 : 'a1 -> 'a1 dop -> 'a1 -> 'a1 -> 'a1 + +val dop_inv_rect_Type4 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 + +val dop_inv_rect_Type3 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 + +val dop_inv_rect_Type2 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 + +val dop_inv_rect_Type1 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 + +val dop_inv_rect_Type0 : + 'a1 -> 'a1 dop -> ('a1 aCop -> ('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> + 'a2) -> 'a2 + +val dop_discr : 'a1 -> 'a1 dop -> 'a1 dop -> __ + diff --git a/extracted/bindLists.ml b/extracted/bindLists.ml new file mode 100644 index 0000000..08fda04 --- /dev/null +++ b/extracted/bindLists.ml @@ -0,0 +1,87 @@ +open Preamble + +open State + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Monad + +open Bind_new + +type ('b, 'e) bind_list = ('b, 'e List.list) Bind_new.bind_new + +(** val dpi1__o__blist_from_list__o__inject : + ('a2 List.list, 'a3) Types.dPair -> ('a1, 'a2 List.list) + Bind_new.bind_new Types.sig0 **) +let dpi1__o__blist_from_list__o__inject x4 = + Bind_new.Bret x4.Types.dpi1 + +(** val eject__o__blist_from_list__o__inject : + 'a2 List.list Types.sig0 -> ('a1, 'a2 List.list) Bind_new.bind_new + Types.sig0 **) +let eject__o__blist_from_list__o__inject x4 = + Bind_new.Bret (Types.pi1 x4) + +(** val blist_from_list__o__inject : + 'a2 List.list -> ('a1, 'a2 List.list) Bind_new.bind_new Types.sig0 **) +let blist_from_list__o__inject x3 = + Bind_new.Bret x3 + +(** val dpi1__o__blist_from_list : + ('a2 List.list, 'a3) Types.dPair -> ('a1, 'a2 List.list) + Bind_new.bind_new **) +let dpi1__o__blist_from_list x3 = + let l = x3.Types.dpi1 in Bind_new.Bret l + +(** val eject__o__blist_from_list : + 'a2 List.list Types.sig0 -> ('a1, 'a2 List.list) Bind_new.bind_new **) +let eject__o__blist_from_list x3 = + let l = Types.pi1 x3 in Bind_new.Bret l + +(** val bappend : + ('a1, 'a2) bind_list -> ('a1, 'a2) bind_list -> ('a1, 'a2) bind_list **) +let bappend x = + Obj.magic + (Monad.m_bin_op (Monad.max_def Bind_new.bindNew) List.append + (Obj.magic x)) + +open Option + +open Extranat + +open Div_and_mod + +open Util + +open Vector + +(** val bcons : 'a2 -> ('a1, 'a2) bind_list -> ('a1, 'a2) bind_list **) +let bcons e = + Obj.magic + (Monad.m_map (Monad.max_def Bind_new.bindNew) (fun x -> List.Cons (e, + x))) + +open Lists + diff --git a/extracted/bindLists.mli b/extracted/bindLists.mli new file mode 100644 index 0000000..c2b8e8f --- /dev/null +++ b/extracted/bindLists.mli @@ -0,0 +1,68 @@ +open Preamble + +open State + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Monad + +open Bind_new + +type ('b, 'e) bind_list = ('b, 'e List.list) Bind_new.bind_new + +val dpi1__o__blist_from_list__o__inject : + ('a2 List.list, 'a3) Types.dPair -> ('a1, 'a2 List.list) Bind_new.bind_new + Types.sig0 + +val eject__o__blist_from_list__o__inject : + 'a2 List.list Types.sig0 -> ('a1, 'a2 List.list) Bind_new.bind_new + Types.sig0 + +val blist_from_list__o__inject : + 'a2 List.list -> ('a1, 'a2 List.list) Bind_new.bind_new Types.sig0 + +val dpi1__o__blist_from_list : + ('a2 List.list, 'a3) Types.dPair -> ('a1, 'a2 List.list) Bind_new.bind_new + +val eject__o__blist_from_list : + 'a2 List.list Types.sig0 -> ('a1, 'a2 List.list) Bind_new.bind_new + +val bappend : + ('a1, 'a2) bind_list -> ('a1, 'a2) bind_list -> ('a1, 'a2) bind_list + +open Option + +open Extranat + +open Div_and_mod + +open Util + +open Vector + +val bcons : 'a2 -> ('a1, 'a2) bind_list -> ('a1, 'a2) bind_list + +open Lists + diff --git a/extracted/bind_new.ml b/extracted/bind_new.ml new file mode 100644 index 0000000..b46b909 --- /dev/null +++ b/extracted/bind_new.ml @@ -0,0 +1,162 @@ +open Preamble + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Monad + +type ('b, 'e) bind_new = +| Bret of 'e +| Bnew of ('b -> ('b, 'e) bind_new) + +(** val bind_new_rect_Type4 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 **) +let rec bind_new_rect_Type4 h_bret h_bnew = function +| Bret x_18204 -> h_bret x_18204 +| Bnew x_18206 -> + h_bnew x_18206 (fun x_18205 -> + bind_new_rect_Type4 h_bret h_bnew (x_18206 x_18205)) + +(** val bind_new_rect_Type3 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 **) +let rec bind_new_rect_Type3 h_bret h_bnew = function +| Bret x_18216 -> h_bret x_18216 +| Bnew x_18218 -> + h_bnew x_18218 (fun x_18217 -> + bind_new_rect_Type3 h_bret h_bnew (x_18218 x_18217)) + +(** val bind_new_rect_Type2 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 **) +let rec bind_new_rect_Type2 h_bret h_bnew = function +| Bret x_18222 -> h_bret x_18222 +| Bnew x_18224 -> + h_bnew x_18224 (fun x_18223 -> + bind_new_rect_Type2 h_bret h_bnew (x_18224 x_18223)) + +(** val bind_new_rect_Type1 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 **) +let rec bind_new_rect_Type1 h_bret h_bnew = function +| Bret x_18228 -> h_bret x_18228 +| Bnew x_18230 -> + h_bnew x_18230 (fun x_18229 -> + bind_new_rect_Type1 h_bret h_bnew (x_18230 x_18229)) + +(** val bind_new_rect_Type0 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 **) +let rec bind_new_rect_Type0 h_bret h_bnew = function +| Bret x_18234 -> h_bret x_18234 +| Bnew x_18236 -> + h_bnew x_18236 (fun x_18235 -> + bind_new_rect_Type0 h_bret h_bnew (x_18236 x_18235)) + +(** val bind_new_inv_rect_Type4 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) + bind_new) -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 **) +let bind_new_inv_rect_Type4 hterm h1 h2 = + let hcut = bind_new_rect_Type4 h1 h2 hterm in hcut __ + +(** val bind_new_inv_rect_Type3 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) + bind_new) -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 **) +let bind_new_inv_rect_Type3 hterm h1 h2 = + let hcut = bind_new_rect_Type3 h1 h2 hterm in hcut __ + +(** val bind_new_inv_rect_Type2 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) + bind_new) -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 **) +let bind_new_inv_rect_Type2 hterm h1 h2 = + let hcut = bind_new_rect_Type2 h1 h2 hterm in hcut __ + +(** val bind_new_inv_rect_Type1 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) + bind_new) -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 **) +let bind_new_inv_rect_Type1 hterm h1 h2 = + let hcut = bind_new_rect_Type1 h1 h2 hterm in hcut __ + +(** val bind_new_inv_rect_Type0 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) + bind_new) -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 **) +let bind_new_inv_rect_Type0 hterm h1 h2 = + let hcut = bind_new_rect_Type0 h1 h2 hterm in hcut __ + +(** val bind_new_discr : ('a1, 'a2) bind_new -> ('a1, 'a2) bind_new -> __ **) +let bind_new_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Bret a0 -> Obj.magic (fun _ dH -> dH __) + | Bnew a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val bind_new_jmdiscr : + ('a1, 'a2) bind_new -> ('a1, 'a2) bind_new -> __ **) +let bind_new_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Bret a0 -> Obj.magic (fun _ dH -> dH __) + | Bnew a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val bnews : + Nat.nat -> ('a1 List.list -> ('a1, 'a2) bind_new) -> ('a1, 'a2) bind_new **) +let rec bnews n f = + match n with + | Nat.O -> f List.Nil + | Nat.S x -> Bnew (fun y -> bnews x (fun l -> f (List.Cons (y, l)))) + +(** val bnews_strong : + Nat.nat -> ('a1 List.list -> __ -> ('a1, 'a2) bind_new) -> ('a1, 'a2) + bind_new **) +let rec bnews_strong n f = + (match n with + | Nat.O -> (fun _ -> f List.Nil __) + | Nat.S n' -> + (fun _ -> Bnew (fun x -> + bnews_strong n' (fun l' _ -> f (List.Cons (x, l')) __)))) __ + +(** val bbind : + ('a1, 'a2) bind_new -> ('a2 -> ('a1, 'a3) bind_new) -> ('a1, 'a3) + bind_new **) +let rec bbind l f = + match l with + | Bret x -> f x + | Bnew n -> Bnew (fun x -> bbind (n x) f) + +(** val bindNew : Monad.monadProps **) +let bindNew = + Monad.makeMonadProps (fun _ x -> Bret x) (fun _ _ -> bbind) + +open State + +(** val bcompile : + 'a2 Monad.smax_def__o__monad -> ('a2, 'a3) bind_new -> 'a3 + Monad.smax_def__o__monad **) +let rec bcompile fresh = function +| Bret x -> Monad.m_return0 (Monad.smax_def State.state_monad) x +| Bnew f -> + Monad.m_bind0 (Monad.smax_def State.state_monad) fresh (fun r -> + bcompile fresh (f r)) + diff --git a/extracted/bind_new.mli b/extracted/bind_new.mli new file mode 100644 index 0000000..9f2c672 --- /dev/null +++ b/extracted/bind_new.mli @@ -0,0 +1,94 @@ +open Preamble + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Monad + +type ('b, 'e) bind_new = +| Bret of 'e +| Bnew of ('b -> ('b, 'e) bind_new) + +val bind_new_rect_Type4 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 + +val bind_new_rect_Type3 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 + +val bind_new_rect_Type2 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 + +val bind_new_rect_Type1 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 + +val bind_new_rect_Type0 : + ('a2 -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) -> ('a1 -> 'a3) -> 'a3) -> + ('a1, 'a2) bind_new -> 'a3 + +val bind_new_inv_rect_Type4 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) + -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 + +val bind_new_inv_rect_Type3 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) + -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 + +val bind_new_inv_rect_Type2 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) + -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 + +val bind_new_inv_rect_Type1 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) + -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 + +val bind_new_inv_rect_Type0 : + ('a1, 'a2) bind_new -> ('a2 -> __ -> 'a3) -> (('a1 -> ('a1, 'a2) bind_new) + -> ('a1 -> __ -> 'a3) -> __ -> 'a3) -> 'a3 + +val bind_new_discr : ('a1, 'a2) bind_new -> ('a1, 'a2) bind_new -> __ + +val bind_new_jmdiscr : ('a1, 'a2) bind_new -> ('a1, 'a2) bind_new -> __ + +val bnews : + Nat.nat -> ('a1 List.list -> ('a1, 'a2) bind_new) -> ('a1, 'a2) bind_new + +val bnews_strong : + Nat.nat -> ('a1 List.list -> __ -> ('a1, 'a2) bind_new) -> ('a1, 'a2) + bind_new + +val bbind : + ('a1, 'a2) bind_new -> ('a2 -> ('a1, 'a3) bind_new) -> ('a1, 'a3) bind_new + +val bindNew : Monad.monadProps + +open State + +val bcompile : + 'a2 Monad.smax_def__o__monad -> ('a2, 'a3) bind_new -> 'a3 + Monad.smax_def__o__monad + diff --git a/extracted/bitVector.ml b/extracted/bitVector.ml new file mode 100644 index 0000000..c5ae16d --- /dev/null +++ b/extracted/bitVector.ml @@ -0,0 +1,110 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Div_and_mod + +open Jmeq + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +type bitVector = Bool.bool Vector.vector + +type bit = Bool.bool + +type nibble = bitVector + +type byte7 = bitVector + +type byte = bitVector + +type word = bitVector + +type word11 = bitVector + +(** val zero : Nat.nat -> bitVector **) +let zero n = + Vector.replicate n Bool.False + +(** val maximum : Nat.nat -> bitVector **) +let maximum n = + Vector.replicate n Bool.True + +(** val pad : Nat.nat -> Nat.nat -> bitVector -> Bool.bool Vector.vector **) +let pad m n b = + Vector.pad_vector Bool.False m n b + +(** val conjunction_bv : Nat.nat -> bitVector -> bitVector -> bitVector **) +let conjunction_bv n b c = + Vector.zip_with n Bool.andb b c + +(** val inclusive_disjunction_bv : + Nat.nat -> bitVector -> bitVector -> Bool.bool Vector.vector **) +let inclusive_disjunction_bv n b c = + Vector.zip_with n Bool.orb b c + +(** val exclusive_disjunction_bv : + Nat.nat -> bitVector -> bitVector -> Bool.bool Vector.vector **) +let exclusive_disjunction_bv n b c = + Vector.zip_with n Bool.xorb b c + +(** val negation_bv : Nat.nat -> bitVector -> Bool.bool Vector.vector **) +let negation_bv n b = + Vector.map n Bool.notb b + +(** val eq_b : Bool.bool -> Bool.bool -> Bool.bool **) +let eq_b b c = + match b with + | Bool.True -> c + | Bool.False -> Bool.notb c + +(** val eq_bv : Nat.nat -> bitVector -> bitVector -> Bool.bool **) +let eq_bv n b c = + Vector.eq_v n eq_b b c + +(** val eq_bv_elim : + Nat.nat -> bitVector -> bitVector -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let eq_bv_elim n x y ht hf = + Vector.eq_v_elim eq_b (fun _ clearme -> + match clearme with + | Bool.True -> + (fun clearme0 -> + match clearme0 with + | Bool.True -> (fun auto auto' -> auto __) + | Bool.False -> (fun auto auto' -> auto' __)) + | Bool.False -> + (fun clearme0 -> + match clearme0 with + | Bool.True -> (fun auto auto' -> auto' __) + | Bool.False -> (fun auto auto' -> auto __))) n x y ht hf + diff --git a/extracted/bitVector.mli b/extracted/bitVector.mli new file mode 100644 index 0000000..d22dc34 --- /dev/null +++ b/extracted/bitVector.mli @@ -0,0 +1,77 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Div_and_mod + +open Jmeq + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +type bitVector = Bool.bool Vector.vector + +type bit = Bool.bool + +type nibble = bitVector + +type byte7 = bitVector + +type byte = bitVector + +type word = bitVector + +type word11 = bitVector + +val zero : Nat.nat -> bitVector + +val maximum : Nat.nat -> bitVector + +val pad : Nat.nat -> Nat.nat -> bitVector -> Bool.bool Vector.vector + +val conjunction_bv : Nat.nat -> bitVector -> bitVector -> bitVector + +val inclusive_disjunction_bv : + Nat.nat -> bitVector -> bitVector -> Bool.bool Vector.vector + +val exclusive_disjunction_bv : + Nat.nat -> bitVector -> bitVector -> Bool.bool Vector.vector + +val negation_bv : Nat.nat -> bitVector -> Bool.bool Vector.vector + +val eq_b : Bool.bool -> Bool.bool -> Bool.bool + +val eq_bv : Nat.nat -> bitVector -> bitVector -> Bool.bool + +val eq_bv_elim : + Nat.nat -> bitVector -> bitVector -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + diff --git a/extracted/bitVectorTrie.ml b/extracted/bitVectorTrie.ml new file mode 100644 index 0000000..69f9e0d --- /dev/null +++ b/extracted/bitVectorTrie.ml @@ -0,0 +1,322 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +type 'a bitVectorTrie = +| Leaf of 'a +| Node of Nat.nat * 'a bitVectorTrie * 'a bitVectorTrie +| Stub of Nat.nat + +(** val bitVectorTrie_rect_Type4 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 **) +let rec bitVectorTrie_rect_Type4 h_Leaf h_Node h_Stub x_14760 = function +| Leaf x_14762 -> h_Leaf x_14762 +| Node (n, x_14764, x_14763) -> + h_Node n x_14764 x_14763 + (bitVectorTrie_rect_Type4 h_Leaf h_Node h_Stub n x_14764) + (bitVectorTrie_rect_Type4 h_Leaf h_Node h_Stub n x_14763) +| Stub n -> h_Stub n + +(** val bitVectorTrie_rect_Type3 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 **) +let rec bitVectorTrie_rect_Type3 h_Leaf h_Node h_Stub x_14776 = function +| Leaf x_14778 -> h_Leaf x_14778 +| Node (n, x_14780, x_14779) -> + h_Node n x_14780 x_14779 + (bitVectorTrie_rect_Type3 h_Leaf h_Node h_Stub n x_14780) + (bitVectorTrie_rect_Type3 h_Leaf h_Node h_Stub n x_14779) +| Stub n -> h_Stub n + +(** val bitVectorTrie_rect_Type2 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 **) +let rec bitVectorTrie_rect_Type2 h_Leaf h_Node h_Stub x_14784 = function +| Leaf x_14786 -> h_Leaf x_14786 +| Node (n, x_14788, x_14787) -> + h_Node n x_14788 x_14787 + (bitVectorTrie_rect_Type2 h_Leaf h_Node h_Stub n x_14788) + (bitVectorTrie_rect_Type2 h_Leaf h_Node h_Stub n x_14787) +| Stub n -> h_Stub n + +(** val bitVectorTrie_rect_Type1 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 **) +let rec bitVectorTrie_rect_Type1 h_Leaf h_Node h_Stub x_14792 = function +| Leaf x_14794 -> h_Leaf x_14794 +| Node (n, x_14796, x_14795) -> + h_Node n x_14796 x_14795 + (bitVectorTrie_rect_Type1 h_Leaf h_Node h_Stub n x_14796) + (bitVectorTrie_rect_Type1 h_Leaf h_Node h_Stub n x_14795) +| Stub n -> h_Stub n + +(** val bitVectorTrie_rect_Type0 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 **) +let rec bitVectorTrie_rect_Type0 h_Leaf h_Node h_Stub x_14800 = function +| Leaf x_14802 -> h_Leaf x_14802 +| Node (n, x_14804, x_14803) -> + h_Node n x_14804 x_14803 + (bitVectorTrie_rect_Type0 h_Leaf h_Node h_Stub n x_14804) + (bitVectorTrie_rect_Type0 h_Leaf h_Node h_Stub n x_14803) +| Stub n -> h_Stub n + +(** val bitVectorTrie_inv_rect_Type4 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> + 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ + -> 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 **) +let bitVectorTrie_inv_rect_Type4 x2 hterm h1 h2 h3 = + let hcut = bitVectorTrie_rect_Type4 h1 h2 h3 x2 hterm in hcut __ __ + +(** val bitVectorTrie_inv_rect_Type3 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> + 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ + -> 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 **) +let bitVectorTrie_inv_rect_Type3 x2 hterm h1 h2 h3 = + let hcut = bitVectorTrie_rect_Type3 h1 h2 h3 x2 hterm in hcut __ __ + +(** val bitVectorTrie_inv_rect_Type2 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> + 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ + -> 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 **) +let bitVectorTrie_inv_rect_Type2 x2 hterm h1 h2 h3 = + let hcut = bitVectorTrie_rect_Type2 h1 h2 h3 x2 hterm in hcut __ __ + +(** val bitVectorTrie_inv_rect_Type1 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> + 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ + -> 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 **) +let bitVectorTrie_inv_rect_Type1 x2 hterm h1 h2 h3 = + let hcut = bitVectorTrie_rect_Type1 h1 h2 h3 x2 hterm in hcut __ __ + +(** val bitVectorTrie_inv_rect_Type0 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> + 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ + -> 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 **) +let bitVectorTrie_inv_rect_Type0 x2 hterm h1 h2 h3 = + let hcut = bitVectorTrie_rect_Type0 h1 h2 h3 x2 hterm in hcut __ __ + +(** val bitVectorTrie_discr : + Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> __ **) +let bitVectorTrie_discr a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Leaf a0 -> Obj.magic (fun _ dH -> dH __) + | Node (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Stub a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val bitVectorTrie_jmdiscr : + Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> __ **) +let bitVectorTrie_jmdiscr a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Leaf a0 -> Obj.magic (fun _ dH -> dH __) + | Node (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Stub a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val fold : + Nat.nat -> (BitVector.bitVector -> 'a1 -> 'a2 -> 'a2) -> 'a1 + bitVectorTrie -> 'a2 -> 'a2 **) +let rec fold n f t b = + (match t with + | Leaf l -> (fun _ -> f (BitVector.zero n) l b) + | Node (h, l, r) -> + (fun _ -> + fold h (fun x -> f (Vector.VCons (h, Bool.False, x))) l + (fold h (fun x -> f (Vector.VCons (h, Bool.True, x))) r b)) + | Stub x -> (fun _ -> b)) __ + +(** val bvtfold_aux : + (BitVector.bitVector -> 'a1 -> 'a2 -> 'a2) -> 'a2 -> Nat.nat -> 'a1 + bitVectorTrie -> BitVector.bitVector -> 'a2 **) +let rec bvtfold_aux f seed n x x0 = + (match n with + | Nat.O -> + (fun _ trie path -> + (match trie with + | Leaf l -> (fun _ -> f path l seed) + | Node (n', l, r) -> (fun _ -> assert false (* absurd case *)) + | Stub s -> (fun _ -> seed)) __) + | Nat.S n' -> + (fun _ trie path -> + (match trie with + | Leaf l -> (fun _ -> assert false (* absurd case *)) + | Node (n'', l, r) -> + (fun _ -> + bvtfold_aux f + (bvtfold_aux f seed n' l (Vector.VCons + ((Nat.minus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) (Nat.S n')), Bool.False, + path))) n' r (Vector.VCons + ((Nat.minus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) (Nat.S n')), Bool.True, path))) + | Stub s -> (fun _ -> seed)) __)) __ x x0 + +(** val lookup_opt : + Nat.nat -> BitVector.bitVector -> 'a1 bitVectorTrie -> 'a1 Types.option **) +let rec lookup_opt n b t = + (match t with + | Leaf l -> (fun x -> Types.Some l) + | Node (h, l, r) -> + (fun b0 -> + lookup_opt h (Vector.tail h b0) + (match Vector.head' h b0 with + | Bool.True -> r + | Bool.False -> l)) + | Stub x -> (fun x0 -> Types.None)) b + +(** val member : + Nat.nat -> BitVector.bitVector -> 'a1 bitVectorTrie -> Bool.bool **) +let member n b t = + match lookup_opt n b t with + | Types.None -> Bool.False + | Types.Some x -> Bool.True + +(** val lookup : + Nat.nat -> BitVector.bitVector -> 'a1 bitVectorTrie -> 'a1 -> 'a1 **) +let rec lookup n b t a = + (match b with + | Vector.VEmpty -> + (match t with + | Leaf l -> (fun _ -> l) + | Node (h, l, r) -> (fun _ -> assert false (* absurd case *)) + | Stub s -> (fun _ -> a)) + | Vector.VCons (o, hd, tl) -> + (match t with + | Leaf l -> (fun _ -> assert false (* absurd case *)) + | Node (h, l, r) -> + (match hd with + | Bool.True -> (fun _ -> lookup h tl r a) + | Bool.False -> (fun _ -> lookup h tl l a)) + | Stub s -> (fun _ -> a))) __ + +(** val prepare_trie_for_insertion : + Nat.nat -> BitVector.bitVector -> 'a1 -> 'a1 bitVectorTrie **) +let rec prepare_trie_for_insertion n b a = + match b with + | Vector.VEmpty -> Leaf a + | Vector.VCons (o, hd, tl) -> + (match hd with + | Bool.True -> Node (o, (Stub o), (prepare_trie_for_insertion o tl a)) + | Bool.False -> Node (o, (prepare_trie_for_insertion o tl a), (Stub o))) + +(** val insert : + Nat.nat -> BitVector.bitVector -> 'a1 -> 'a1 bitVectorTrie -> 'a1 + bitVectorTrie **) +let rec insert n b a = + match b with + | Vector.VEmpty -> (fun x -> Leaf a) + | Vector.VCons (o, hd, tl) -> + (fun t -> + (match t with + | Leaf l -> (fun _ -> assert false (* absurd case *)) + | Node (p, l, r) -> + (fun _ -> + match hd with + | Bool.True -> Node (o, l, (insert o tl a r)) + | Bool.False -> Node (o, (insert o tl a l), r)) + | Stub p -> + (fun _ -> + prepare_trie_for_insertion (Nat.S o) (Vector.VCons (o, hd, tl)) a)) + __) + +(** val update : + Nat.nat -> BitVector.bitVector -> 'a1 -> 'a1 bitVectorTrie -> 'a1 + bitVectorTrie Types.option **) +let rec update n b a = + match b with + | Vector.VEmpty -> + (fun t -> + (match t with + | Leaf x -> (fun _ -> Types.Some (Leaf a)) + | Node (x, x0, x1) -> (fun _ -> assert false (* absurd case *)) + | Stub x -> (fun _ -> Types.None)) __) + | Vector.VCons (o, hd, tl) -> + (fun t -> + (match t with + | Leaf l -> (fun _ -> assert false (* absurd case *)) + | Node (p, l, r) -> + (fun _ -> + match hd with + | Bool.True -> + Types.option_map (fun v -> Node (o, l, v)) (update o tl a r) + | Bool.False -> + Types.option_map (fun v -> Node (o, v, r)) (update o tl a l)) + | Stub p -> (fun _ -> Types.None)) __) + +(** val merge : + Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie **) +let rec merge n = function +| Leaf l -> + (fun c -> + match c with + | Leaf a -> Leaf a + | Node (x, x0, x1) -> Leaf l + | Stub x -> Leaf l) +| Node (p, l, r) -> + (fun c -> + (match c with + | Leaf x -> (fun _ -> Obj.magic Nat.nat_discr Nat.O (Nat.S p) __) + | Node (p', l', r') -> + (fun _ -> Node (p, (merge p l l'), (merge p r r'))) + | Stub x -> (fun _ -> Node (p, l, r))) __) +| Stub x -> (fun c -> c) + +open Deqsets + +type strong_decidable = (__, __) Types.sum + +(** val strong_decidable_in_codomain : + Deqsets.deqSet -> Nat.nat -> __ bitVectorTrie -> __ -> strong_decidable **) +let strong_decidable_in_codomain a n m = + bitVectorTrie_rect_Type0 (fun a' a0 -> + Bool.bool_inv_rect_Type0 (Deqsets.eqb a a' a0) (fun _ -> Types.Inl __) + (fun _ -> Types.Inr __)) (fun n0 l r hl hr a0 -> + match hl a0 with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> + (match hr a0 with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __)) (fun n0 a0 -> Types.Inr __) n m + diff --git a/extracted/bitVectorTrie.mli b/extracted/bitVectorTrie.mli new file mode 100644 index 0000000..7011db9 --- /dev/null +++ b/extracted/bitVectorTrie.mli @@ -0,0 +1,135 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +type 'a bitVectorTrie = +| Leaf of 'a +| Node of Nat.nat * 'a bitVectorTrie * 'a bitVectorTrie +| Stub of Nat.nat + +val bitVectorTrie_rect_Type4 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 + +val bitVectorTrie_rect_Type3 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 + +val bitVectorTrie_rect_Type2 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 + +val bitVectorTrie_rect_Type1 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 + +val bitVectorTrie_rect_Type0 : + ('a1 -> 'a2) -> (Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a2 + -> 'a2 -> 'a2) -> (Nat.nat -> 'a2) -> Nat.nat -> 'a1 bitVectorTrie -> 'a2 + +val bitVectorTrie_inv_rect_Type4 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> 'a1 + bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ -> + 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 + +val bitVectorTrie_inv_rect_Type3 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> 'a1 + bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ -> + 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 + +val bitVectorTrie_inv_rect_Type2 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> 'a1 + bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ -> + 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 + +val bitVectorTrie_inv_rect_Type1 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> 'a1 + bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ -> + 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 + +val bitVectorTrie_inv_rect_Type0 : + Nat.nat -> 'a1 bitVectorTrie -> ('a1 -> __ -> __ -> 'a2) -> (Nat.nat -> 'a1 + bitVectorTrie -> 'a1 bitVectorTrie -> (__ -> __ -> 'a2) -> (__ -> __ -> + 'a2) -> __ -> __ -> 'a2) -> (Nat.nat -> __ -> __ -> 'a2) -> 'a2 + +val bitVectorTrie_discr : + Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> __ + +val bitVectorTrie_jmdiscr : + Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> __ + +val fold : + Nat.nat -> (BitVector.bitVector -> 'a1 -> 'a2 -> 'a2) -> 'a1 bitVectorTrie + -> 'a2 -> 'a2 + +val bvtfold_aux : + (BitVector.bitVector -> 'a1 -> 'a2 -> 'a2) -> 'a2 -> Nat.nat -> 'a1 + bitVectorTrie -> BitVector.bitVector -> 'a2 + +val lookup_opt : + Nat.nat -> BitVector.bitVector -> 'a1 bitVectorTrie -> 'a1 Types.option + +val member : Nat.nat -> BitVector.bitVector -> 'a1 bitVectorTrie -> Bool.bool + +val lookup : + Nat.nat -> BitVector.bitVector -> 'a1 bitVectorTrie -> 'a1 -> 'a1 + +val prepare_trie_for_insertion : + Nat.nat -> BitVector.bitVector -> 'a1 -> 'a1 bitVectorTrie + +val insert : + Nat.nat -> BitVector.bitVector -> 'a1 -> 'a1 bitVectorTrie -> 'a1 + bitVectorTrie + +val update : + Nat.nat -> BitVector.bitVector -> 'a1 -> 'a1 bitVectorTrie -> 'a1 + bitVectorTrie Types.option + +val merge : + Nat.nat -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie -> 'a1 bitVectorTrie + +open Deqsets + +type strong_decidable = (__, __) Types.sum + +val strong_decidable_in_codomain : + Deqsets.deqSet -> Nat.nat -> __ bitVectorTrie -> __ -> strong_decidable + diff --git a/extracted/bitVectorTrieSet.ml b/extracted/bitVectorTrieSet.ml new file mode 100644 index 0000000..9a243c7 --- /dev/null +++ b/extracted/bitVectorTrieSet.ml @@ -0,0 +1,120 @@ +open Preamble + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open BitVectorTrie + +type bitVectorTrieSet = Types.unit0 BitVectorTrie.bitVectorTrie + +(** val set_member : + Nat.nat -> Bool.bool Vector.vector -> bitVectorTrieSet -> Bool.bool **) +let rec set_member n p b = + (match p with + | Vector.VEmpty -> + (match b with + | BitVectorTrie.Leaf x -> (fun _ -> Bool.True) + | BitVectorTrie.Node (x, x0, x1) -> + (fun _ -> Obj.magic Nat.nat_discr (Nat.S x) Nat.O __) + | BitVectorTrie.Stub x -> (fun _ -> Bool.False)) + | Vector.VCons (o, hd, tl) -> + (match b with + | BitVectorTrie.Leaf x -> + (fun _ -> Obj.magic Nat.nat_discr Nat.O (Nat.S o) __) + | BitVectorTrie.Node (p0, l, r) -> + (match hd with + | Bool.True -> (fun _ -> set_member o tl r) + | Bool.False -> (fun _ -> set_member o tl l)) + | BitVectorTrie.Stub x -> (fun _ -> Bool.False))) __ + +(** val set_union : + Nat.nat -> bitVectorTrieSet -> bitVectorTrieSet -> bitVectorTrieSet **) +let rec set_union n = function +| BitVectorTrie.Leaf l -> (fun c -> BitVectorTrie.Leaf l) +| BitVectorTrie.Node (p, l, r) -> + (fun c -> + (match c with + | BitVectorTrie.Leaf x -> + (fun _ -> Obj.magic Nat.nat_discr Nat.O (Nat.S p) __) + | BitVectorTrie.Node (p', l', r') -> + (fun _ -> BitVectorTrie.Node (p, (set_union p l l'), + (set_union p r r'))) + | BitVectorTrie.Stub x -> (fun _ -> BitVectorTrie.Node (p, l, r))) __) +| BitVectorTrie.Stub x -> (fun c -> c) + +(** val set_eq : + Nat.nat -> bitVectorTrieSet -> bitVectorTrieSet -> Bool.bool **) +let rec set_eq n b c = + (match b with + | BitVectorTrie.Leaf l -> + (match c with + | BitVectorTrie.Leaf l' -> (fun _ -> Bool.True) + | BitVectorTrie.Node (x, x0, x1) -> (fun _ -> Bool.False) + | BitVectorTrie.Stub x -> (fun _ -> Bool.False)) + | BitVectorTrie.Node (h, l, r) -> + (match c with + | BitVectorTrie.Leaf x -> (fun _ -> Bool.False) + | BitVectorTrie.Node (h', l', r') -> + (fun _ -> + Bool.andb (set_eq h l r) (set_eq h r (Logic.eq_rect_Type0 h' r' h))) + | BitVectorTrie.Stub x -> (fun _ -> Bool.False)) + | BitVectorTrie.Stub s -> + (match c with + | BitVectorTrie.Leaf x -> (fun _ -> Bool.False) + | BitVectorTrie.Node (x, x0, x1) -> (fun _ -> Bool.False) + | BitVectorTrie.Stub s' -> (fun _ -> Util.eq_nat s s'))) __ + +(** val set_insert : + Nat.nat -> BitVector.bitVector -> bitVectorTrieSet -> Types.unit0 + BitVectorTrie.bitVectorTrie **) +let set_insert n b s = + BitVectorTrie.insert n b Types.It s + +(** val set_empty : Nat.nat -> Types.unit0 BitVectorTrie.bitVectorTrie **) +let set_empty n = + BitVectorTrie.Stub n + +(** val set_singleton : + Nat.nat -> BitVector.bitVector -> Types.unit0 BitVectorTrie.bitVectorTrie **) +let set_singleton n b = + BitVectorTrie.insert n b Types.It (set_empty n) + diff --git a/extracted/bitVectorTrieSet.mli b/extracted/bitVectorTrieSet.mli new file mode 100644 index 0000000..0c5586a --- /dev/null +++ b/extracted/bitVectorTrieSet.mli @@ -0,0 +1,65 @@ +open Preamble + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open BitVectorTrie + +type bitVectorTrieSet = Types.unit0 BitVectorTrie.bitVectorTrie + +val set_member : + Nat.nat -> Bool.bool Vector.vector -> bitVectorTrieSet -> Bool.bool + +val set_union : + Nat.nat -> bitVectorTrieSet -> bitVectorTrieSet -> bitVectorTrieSet + +val set_eq : Nat.nat -> bitVectorTrieSet -> bitVectorTrieSet -> Bool.bool + +val set_insert : + Nat.nat -> BitVector.bitVector -> bitVectorTrieSet -> Types.unit0 + BitVectorTrie.bitVectorTrie + +val set_empty : Nat.nat -> Types.unit0 BitVectorTrie.bitVectorTrie + +val set_singleton : + Nat.nat -> BitVector.bitVector -> Types.unit0 BitVectorTrie.bitVectorTrie + diff --git a/extracted/bitVectorZ.ml b/extracted/bitVectorZ.ml new file mode 100644 index 0000000..6c1a912 --- /dev/null +++ b/extracted/bitVectorZ.ml @@ -0,0 +1,123 @@ +open Preamble + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Exp + +open Arithmetic + +open Division + +(** val z_of_unsigned_bitvector : Nat.nat -> BitVector.bitVector -> Z.z **) +let rec z_of_unsigned_bitvector n = function +| Vector.VEmpty -> Z.OZ +| Vector.VCons (n', h, t) -> + (match h with + | Bool.True -> + Z.Pos + (Vector.fold_left n' (fun acc b -> + match b with + | Bool.True -> Positive.P1 acc + | Bool.False -> Positive.P0 acc) Positive.One t) + | Bool.False -> z_of_unsigned_bitvector n' t) + +(** val z_of_signed_bitvector : Nat.nat -> BitVector.bitVector -> Z.z **) +let z_of_signed_bitvector n = function +| Vector.VEmpty -> Z.OZ +| Vector.VCons (n', h, t) -> + (match h with + | Bool.True -> + Z.zopp + (Z.zsucc (z_of_unsigned_bitvector n' (BitVector.negation_bv n' t))) + | Bool.False -> z_of_unsigned_bitvector n' t) + +(** val bits_of_pos : Positive.pos -> Bool.bool List.list **) +let rec bits_of_pos = function +| Positive.One -> List.Cons (Bool.True, List.Nil) +| Positive.P1 p' -> List.Cons (Bool.True, (bits_of_pos p')) +| Positive.P0 p' -> List.Cons (Bool.False, (bits_of_pos p')) + +(** val zeroext_reversed : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let rec zeroext_reversed n m bv = + match m with + | Nat.O -> Vector.VEmpty + | Nat.S m' -> + (match bv with + | Vector.VEmpty -> BitVector.zero (Nat.S m') + | Vector.VCons (n', h, t) -> + Vector.VCons (m', h, (zeroext_reversed n' m' t))) + +(** val bitvector_of_Z : Nat.nat -> Z.z -> BitVector.bitVector **) +let rec bitvector_of_Z n = function +| Z.OZ -> BitVector.zero n +| Z.Pos p -> + let bits = bits_of_pos p in + Vector.reverse n + (zeroext_reversed (List.length bits) n (Vector.vector_of_list bits)) +| Z.Neg p -> + (match p with + | Positive.One -> BitVector.maximum n + | Positive.P1 x -> + let bits = bits_of_pos (Positive.pred p) in + let pz = + Vector.reverse n + (zeroext_reversed (List.length bits) n (Vector.vector_of_list bits)) + in + BitVector.negation_bv n pz + | Positive.P0 x -> + let bits = bits_of_pos (Positive.pred p) in + let pz = + Vector.reverse n + (zeroext_reversed (List.length bits) n (Vector.vector_of_list bits)) + in + BitVector.negation_bv n pz) + +(** val pos_length : Positive.pos -> Nat.nat **) +let rec pos_length = function +| Positive.One -> Nat.O +| Positive.P1 q -> Nat.S (pos_length q) +| Positive.P0 q -> Nat.S (pos_length q) + diff --git a/extracted/bitVectorZ.mli b/extracted/bitVectorZ.mli new file mode 100644 index 0000000..8f0c66e --- /dev/null +++ b/extracted/bitVectorZ.mli @@ -0,0 +1,65 @@ +open Preamble + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Exp + +open Arithmetic + +open Division + +val z_of_unsigned_bitvector : Nat.nat -> BitVector.bitVector -> Z.z + +val z_of_signed_bitvector : Nat.nat -> BitVector.bitVector -> Z.z + +val bits_of_pos : Positive.pos -> Bool.bool List.list + +val zeroext_reversed : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val bitvector_of_Z : Nat.nat -> Z.z -> BitVector.bitVector + +val pos_length : Positive.pos -> Nat.nat + diff --git a/extracted/blocks.ml b/extracted/blocks.ml new file mode 100644 index 0000000..f87f2c8 --- /dev/null +++ b/extracted/blocks.ml @@ -0,0 +1,173 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open State + +open Bind_new + +open BindLists + +(** val bindNewP : Monad.monadPred **) +let bindNewP = + Monad.Mk_MonadPred + +(** val split_on_last : + 'a1 List.list -> ('a1 List.list, 'a1) Types.prod Types.option **) +let split_on_last x = + List.foldr (fun el acc -> + match acc with + | Types.None -> Types.Some { Types.fst = List.Nil; Types.snd = el } + | Types.Some pr -> + Types.Some { Types.fst = (List.Cons (el, pr.Types.fst)); Types.snd = + pr.Types.snd }) Types.None x + +type step_block = + (((__ -> Joint.joint_seq) List.list, __ -> Joint.joint_step) Types.prod, + Joint.joint_seq List.list) Types.prod + +type fin_block = (Joint.joint_seq List.list, Joint.joint_fin_step) Types.prod + +type bind_step_block = (Registers.register, step_block) Bind_new.bind_new + +type bind_fin_block = (Registers.register, fin_block) Bind_new.bind_new + +type bind_seq_list = + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +(** val add_dummy_variance : 'a2 List.list -> ('a1 -> 'a2) List.list **) +let add_dummy_variance x = + List.map (fun x0 x1 -> x0) x + +(** val ensure_step_block : + Joint.params -> AST.ident List.list -> Joint.joint_seq List.list -> + step_block **) +let ensure_step_block p g = function +| List.Nil -> + { Types.fst = { Types.fst = List.Nil; Types.snd = (fun x -> Joint.Step_seq + (Joint.nOOP (Joint.stmt_pars__o__uns_pars__o__u_pars p) g)) }; + Types.snd = List.Nil } +| List.Cons (hd, tl) -> + { Types.fst = { Types.fst = List.Nil; Types.snd = (fun x -> Joint.Step_seq + hd) }; Types.snd = tl } + +(** val map_eval : ('a1 -> 'a2) List.list -> 'a1 -> 'a2 List.list **) +let map_eval l x = + List.map (fun f -> f x) l + diff --git a/extracted/blocks.mli b/extracted/blocks.mli new file mode 100644 index 0000000..6ed163a --- /dev/null +++ b/extracted/blocks.mli @@ -0,0 +1,152 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open State + +open Bind_new + +open BindLists + +val bindNewP : Monad.monadPred + +val split_on_last : + 'a1 List.list -> ('a1 List.list, 'a1) Types.prod Types.option + +type step_block = + (((__ -> Joint.joint_seq) List.list, __ -> Joint.joint_step) Types.prod, + Joint.joint_seq List.list) Types.prod + +type fin_block = (Joint.joint_seq List.list, Joint.joint_fin_step) Types.prod + +type bind_step_block = (Registers.register, step_block) Bind_new.bind_new + +type bind_fin_block = (Registers.register, fin_block) Bind_new.bind_new + +type bind_seq_list = + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +val add_dummy_variance : 'a2 List.list -> ('a1 -> 'a2) List.list + +val ensure_step_block : + Joint.params -> AST.ident List.list -> Joint.joint_seq List.list -> + step_block + +val map_eval : ('a1 -> 'a2) List.list -> 'a1 -> 'a2 List.list + diff --git a/extracted/bool.ml b/extracted/bool.ml new file mode 100644 index 0000000..62dead6 --- /dev/null +++ b/extracted/bool.ml @@ -0,0 +1,102 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +type bool = +| True +| False + +(** val bool_rect_Type4 : 'a1 -> 'a1 -> bool -> 'a1 **) +let rec bool_rect_Type4 h_true h_false = function +| True -> h_true +| False -> h_false + +(** val bool_rect_Type5 : 'a1 -> 'a1 -> bool -> 'a1 **) +let rec bool_rect_Type5 h_true h_false = function +| True -> h_true +| False -> h_false + +(** val bool_rect_Type3 : 'a1 -> 'a1 -> bool -> 'a1 **) +let rec bool_rect_Type3 h_true h_false = function +| True -> h_true +| False -> h_false + +(** val bool_rect_Type2 : 'a1 -> 'a1 -> bool -> 'a1 **) +let rec bool_rect_Type2 h_true h_false = function +| True -> h_true +| False -> h_false + +(** val bool_rect_Type1 : 'a1 -> 'a1 -> bool -> 'a1 **) +let rec bool_rect_Type1 h_true h_false = function +| True -> h_true +| False -> h_false + +(** val bool_rect_Type0 : 'a1 -> 'a1 -> bool -> 'a1 **) +let rec bool_rect_Type0 h_true h_false = function +| True -> h_true +| False -> h_false + +(** val bool_inv_rect_Type4 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let bool_inv_rect_Type4 hterm h1 h2 = + let hcut = bool_rect_Type4 h1 h2 hterm in hcut __ + +(** val bool_inv_rect_Type3 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let bool_inv_rect_Type3 hterm h1 h2 = + let hcut = bool_rect_Type3 h1 h2 hterm in hcut __ + +(** val bool_inv_rect_Type2 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let bool_inv_rect_Type2 hterm h1 h2 = + let hcut = bool_rect_Type2 h1 h2 hterm in hcut __ + +(** val bool_inv_rect_Type1 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let bool_inv_rect_Type1 hterm h1 h2 = + let hcut = bool_rect_Type1 h1 h2 hterm in hcut __ + +(** val bool_inv_rect_Type0 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let bool_inv_rect_Type0 hterm h1 h2 = + let hcut = bool_rect_Type0 h1 h2 hterm in hcut __ + +(** val bool_discr : bool -> bool -> __ **) +let bool_discr x y = + Logic.eq_rect_Type2 x + (match x with + | True -> Obj.magic (fun _ dH -> dH) + | False -> Obj.magic (fun _ dH -> dH)) y + +(** val notb : bool -> bool **) +let notb = function +| True -> False +| False -> True + +(** val andb : bool -> bool -> bool **) +let andb b1 b2 = + match b1 with + | True -> b2 + | False -> False + +(** val orb : bool -> bool -> bool **) +let orb b1 b2 = + match b1 with + | True -> True + | False -> b2 + +(** val xorb : bool -> bool -> bool **) +let xorb b1 b2 = + match b1 with + | True -> + (match b2 with + | True -> False + | False -> True) + | False -> + (match b2 with + | True -> True + | False -> False) + diff --git a/extracted/bool.mli b/extracted/bool.mli new file mode 100644 index 0000000..48e49b9 --- /dev/null +++ b/extracted/bool.mli @@ -0,0 +1,48 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +type bool = +| True +| False + +val bool_rect_Type4 : 'a1 -> 'a1 -> bool -> 'a1 + +val bool_rect_Type5 : 'a1 -> 'a1 -> bool -> 'a1 + +val bool_rect_Type3 : 'a1 -> 'a1 -> bool -> 'a1 + +val bool_rect_Type2 : 'a1 -> 'a1 -> bool -> 'a1 + +val bool_rect_Type1 : 'a1 -> 'a1 -> bool -> 'a1 + +val bool_rect_Type0 : 'a1 -> 'a1 -> bool -> 'a1 + +val bool_inv_rect_Type4 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val bool_inv_rect_Type3 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val bool_inv_rect_Type2 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val bool_inv_rect_Type1 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val bool_inv_rect_Type0 : bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val bool_discr : bool -> bool -> __ + +val notb : bool -> bool + +val andb : bool -> bool -> bool + +val orb : bool -> bool -> bool + +val xorb : bool -> bool -> bool + diff --git a/extracted/build b/extracted/build new file mode 100755 index 0000000..aafcb8b --- /dev/null +++ b/extracted/build @@ -0,0 +1,7 @@ +#!/bin/sh + +# The untrusted ones replace the extracted ones +rm -f set_adt.ml set_adt.mli +# Uses a GNU sed extension +for i in `ls *.ml untrusted/*.ml`; do basename $i | sed -e 's/\(.\)\(.*\)\.ml/\U\1\E\2/'; done > extracted.mlpack +ocamlbuild -Is untrusted -tag debug extracted.cmo diff --git a/extracted/byteValues.ml b/extracted/byteValues.ml new file mode 100644 index 0000000..a12a504 --- /dev/null +++ b/extracted/byteValues.ml @@ -0,0 +1,1092 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open Hide + +type cpointer = Pointers.pointer Types.sig0 + +type xpointer = Pointers.pointer Types.sig0 + +type program_counter = { pc_block : Pointers.block Types.sig0; + pc_offset : Positive.pos } + +(** val program_counter_rect_Type4 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 **) +let rec program_counter_rect_Type4 h_mk_program_counter x_6152 = + let { pc_block = pc_block0; pc_offset = pc_offset0 } = x_6152 in + h_mk_program_counter pc_block0 pc_offset0 + +(** val program_counter_rect_Type5 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 **) +let rec program_counter_rect_Type5 h_mk_program_counter x_6154 = + let { pc_block = pc_block0; pc_offset = pc_offset0 } = x_6154 in + h_mk_program_counter pc_block0 pc_offset0 + +(** val program_counter_rect_Type3 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 **) +let rec program_counter_rect_Type3 h_mk_program_counter x_6156 = + let { pc_block = pc_block0; pc_offset = pc_offset0 } = x_6156 in + h_mk_program_counter pc_block0 pc_offset0 + +(** val program_counter_rect_Type2 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 **) +let rec program_counter_rect_Type2 h_mk_program_counter x_6158 = + let { pc_block = pc_block0; pc_offset = pc_offset0 } = x_6158 in + h_mk_program_counter pc_block0 pc_offset0 + +(** val program_counter_rect_Type1 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 **) +let rec program_counter_rect_Type1 h_mk_program_counter x_6160 = + let { pc_block = pc_block0; pc_offset = pc_offset0 } = x_6160 in + h_mk_program_counter pc_block0 pc_offset0 + +(** val program_counter_rect_Type0 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 **) +let rec program_counter_rect_Type0 h_mk_program_counter x_6162 = + let { pc_block = pc_block0; pc_offset = pc_offset0 } = x_6162 in + h_mk_program_counter pc_block0 pc_offset0 + +(** val pc_block : program_counter -> Pointers.block Types.sig0 **) +let rec pc_block xxx = + xxx.pc_block + +(** val pc_offset : program_counter -> Positive.pos **) +let rec pc_offset xxx = + xxx.pc_offset + +(** val program_counter_inv_rect_Type4 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> + 'a1) -> 'a1 **) +let program_counter_inv_rect_Type4 hterm h1 = + let hcut = program_counter_rect_Type4 h1 hterm in hcut __ + +(** val program_counter_inv_rect_Type3 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> + 'a1) -> 'a1 **) +let program_counter_inv_rect_Type3 hterm h1 = + let hcut = program_counter_rect_Type3 h1 hterm in hcut __ + +(** val program_counter_inv_rect_Type2 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> + 'a1) -> 'a1 **) +let program_counter_inv_rect_Type2 hterm h1 = + let hcut = program_counter_rect_Type2 h1 hterm in hcut __ + +(** val program_counter_inv_rect_Type1 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> + 'a1) -> 'a1 **) +let program_counter_inv_rect_Type1 hterm h1 = + let hcut = program_counter_rect_Type1 h1 hterm in hcut __ + +(** val program_counter_inv_rect_Type0 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> + 'a1) -> 'a1 **) +let program_counter_inv_rect_Type0 hterm h1 = + let hcut = program_counter_rect_Type0 h1 hterm in hcut __ + +(** val program_counter_discr : program_counter -> program_counter -> __ **) +let program_counter_discr x y = + Logic.eq_rect_Type2 x + (let { pc_block = a0; pc_offset = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val program_counter_jmdiscr : + program_counter -> program_counter -> __ **) +let program_counter_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { pc_block = a0; pc_offset = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val eq_program_counter : + program_counter -> program_counter -> Bool.bool **) +let eq_program_counter pc1 pc2 = + Bool.andb + (Pointers.eq_block (Types.pi1 pc1.pc_block) (Types.pi1 pc2.pc_block)) + (Positive.eqb pc1.pc_offset pc2.pc_offset) + +(** val bitvector_from_pos : + Nat.nat -> Positive.pos -> BitVector.bitVector **) +let bitvector_from_pos n p = + BitVectorZ.bitvector_of_Z n (Z.zpred (Z.Pos p)) + +(** val pos_from_bitvector : + Nat.nat -> BitVector.bitVector -> Positive.pos **) +let pos_from_bitvector n v = + (match Z.zsucc (BitVectorZ.z_of_unsigned_bitvector n v) with + | Z.OZ -> (fun _ -> assert false (* absurd case *)) + | Z.Pos x -> (fun _ -> x) + | Z.Neg x -> (fun _ -> assert false (* absurd case *))) __ + +(** val cpointer_of_pc : program_counter -> cpointer Types.option **) +let cpointer_of_pc pc = + let pc_off = pc.pc_offset in + (match Positive.leb pc_off (Positive.two_power_nat Pointers.offset_size) with + | Bool.True -> + Obj.magic + (Monad.m_return0 (Monad.max_def Option.option) { Pointers.pblock = + (Types.pi1 pc.pc_block); Pointers.poff = + (bitvector_from_pos Pointers.offset_size pc_off) }) + | Bool.False -> Types.None) + +type part = + Nat.nat + (* singleton inductive, whose constructor was mk_part *) + +(** val part_rect_Type4 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 **) +let rec part_rect_Type4 h_mk_part x_6178 = + let part_no = x_6178 in h_mk_part part_no __ + +(** val part_rect_Type5 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 **) +let rec part_rect_Type5 h_mk_part x_6180 = + let part_no = x_6180 in h_mk_part part_no __ + +(** val part_rect_Type3 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 **) +let rec part_rect_Type3 h_mk_part x_6182 = + let part_no = x_6182 in h_mk_part part_no __ + +(** val part_rect_Type2 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 **) +let rec part_rect_Type2 h_mk_part x_6184 = + let part_no = x_6184 in h_mk_part part_no __ + +(** val part_rect_Type1 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 **) +let rec part_rect_Type1 h_mk_part x_6186 = + let part_no = x_6186 in h_mk_part part_no __ + +(** val part_rect_Type0 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 **) +let rec part_rect_Type0 h_mk_part x_6188 = + let part_no = x_6188 in h_mk_part part_no __ + +(** val part_no : part -> Nat.nat **) +let rec part_no xxx = + let yyy = xxx in yyy + +(** val part_inv_rect_Type4 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let part_inv_rect_Type4 hterm h1 = + let hcut = part_rect_Type4 h1 hterm in hcut __ + +(** val part_inv_rect_Type3 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let part_inv_rect_Type3 hterm h1 = + let hcut = part_rect_Type3 h1 hterm in hcut __ + +(** val part_inv_rect_Type2 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let part_inv_rect_Type2 hterm h1 = + let hcut = part_rect_Type2 h1 hterm in hcut __ + +(** val part_inv_rect_Type1 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let part_inv_rect_Type1 hterm h1 = + let hcut = part_rect_Type1 h1 hterm in hcut __ + +(** val part_inv_rect_Type0 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 **) +let part_inv_rect_Type0 hterm h1 = + let hcut = part_rect_Type0 h1 hterm in hcut __ + +(** val part_discr : part -> part -> __ **) +let part_discr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val part_jmdiscr : part -> part -> __ **) +let part_jmdiscr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val dpi1__o__part_no__o__inject : + (part, 'a1) Types.dPair -> Nat.nat Types.sig0 **) +let dpi1__o__part_no__o__inject x2 = + part_no x2.Types.dpi1 + +(** val dpi1__o__part_no__o__Z_of_nat : (part, 'a1) Types.dPair -> Z.z **) +let dpi1__o__part_no__o__Z_of_nat x1 = + Z.z_of_nat (part_no x1.Types.dpi1) + +(** val eject__o__part_no__o__inject : + part Types.sig0 -> Nat.nat Types.sig0 **) +let eject__o__part_no__o__inject x2 = + part_no (Types.pi1 x2) + +(** val eject__o__part_no__o__Z_of_nat : part Types.sig0 -> Z.z **) +let eject__o__part_no__o__Z_of_nat x1 = + Z.z_of_nat (part_no (Types.pi1 x1)) + +(** val part_no__o__Z_of_nat : part -> Z.z **) +let part_no__o__Z_of_nat x0 = + Z.z_of_nat (part_no x0) + +(** val part_no__o__inject : part -> Nat.nat Types.sig0 **) +let part_no__o__inject x1 = + part_no x1 + +(** val dpi1__o__part_no : (part, 'a1) Types.dPair -> Nat.nat **) +let dpi1__o__part_no x1 = + part_no x1.Types.dpi1 + +(** val eject__o__part_no : part Types.sig0 -> Nat.nat **) +let eject__o__part_no x1 = + part_no (Types.pi1 x1) + +(** val part_from_sig : Nat.nat Types.sig0 -> part **) +let part_from_sig n_sig = + Types.pi1 n_sig + +(** val dpi1__o__part_no__o__inject__o__sig_to_part__o__inject : + (part, 'a1) Types.dPair -> part Types.sig0 **) +let dpi1__o__part_no__o__inject__o__sig_to_part__o__inject x2 = + part_from_sig (dpi1__o__part_no__o__inject x2) + +(** val dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no__o__inject : + (part, 'a1) Types.dPair -> Nat.nat Types.sig0 **) +let dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no__o__inject x2 = + part_no__o__inject (part_from_sig (dpi1__o__part_no__o__inject x2)) + +(** val dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat : + (part, 'a1) Types.dPair -> Z.z **) +let dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat x1 = + part_no__o__Z_of_nat (part_from_sig (dpi1__o__part_no__o__inject x1)) + +(** val dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no : + (part, 'a1) Types.dPair -> Nat.nat **) +let dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no x1 = + part_no (part_from_sig (dpi1__o__part_no__o__inject x1)) + +(** val eject__o__part_no__o__inject__o__sig_to_part__o__inject : + part Types.sig0 -> part Types.sig0 **) +let eject__o__part_no__o__inject__o__sig_to_part__o__inject x2 = + part_from_sig (eject__o__part_no__o__inject x2) + +(** val eject__o__part_no__o__inject__o__sig_to_part__o__part_no__o__inject : + part Types.sig0 -> Nat.nat Types.sig0 **) +let eject__o__part_no__o__inject__o__sig_to_part__o__part_no__o__inject x2 = + part_no__o__inject (part_from_sig (eject__o__part_no__o__inject x2)) + +(** val eject__o__part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat : + part Types.sig0 -> Z.z **) +let eject__o__part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat x1 = + part_no__o__Z_of_nat (part_from_sig (eject__o__part_no__o__inject x1)) + +(** val eject__o__part_no__o__inject__o__sig_to_part__o__part_no : + part Types.sig0 -> Nat.nat **) +let eject__o__part_no__o__inject__o__sig_to_part__o__part_no x1 = + part_no (part_from_sig (eject__o__part_no__o__inject x1)) + +(** val inject__o__sig_to_part__o__inject : Nat.nat -> part Types.sig0 **) +let inject__o__sig_to_part__o__inject x0 = + part_from_sig x0 + +(** val inject__o__sig_to_part__o__part_no__o__inject : + Nat.nat -> Nat.nat Types.sig0 **) +let inject__o__sig_to_part__o__part_no__o__inject x0 = + part_no__o__inject (part_from_sig x0) + +(** val inject__o__sig_to_part__o__part_no__o__Z_of_nat : Nat.nat -> Z.z **) +let inject__o__sig_to_part__o__part_no__o__Z_of_nat x0 = + part_no__o__Z_of_nat (part_from_sig x0) + +(** val inject__o__sig_to_part__o__part_no : Nat.nat -> Nat.nat **) +let inject__o__sig_to_part__o__part_no x0 = + part_no (part_from_sig x0) + +(** val part_no__o__inject__o__sig_to_part__o__inject : + part -> part Types.sig0 **) +let part_no__o__inject__o__sig_to_part__o__inject x0 = + part_from_sig (part_no__o__inject x0) + +(** val part_no__o__inject__o__sig_to_part__o__part_no__o__inject : + part -> Nat.nat Types.sig0 **) +let part_no__o__inject__o__sig_to_part__o__part_no__o__inject x0 = + part_no__o__inject (part_from_sig (part_no__o__inject x0)) + +(** val part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat : + part -> Z.z **) +let part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat x0 = + part_no__o__Z_of_nat (part_from_sig (part_no__o__inject x0)) + +(** val part_no__o__inject__o__sig_to_part__o__part_no : part -> Nat.nat **) +let part_no__o__inject__o__sig_to_part__o__part_no x0 = + part_no (part_from_sig (part_no__o__inject x0)) + +(** val dpi1__o__sig_to_part__o__inject : + (Nat.nat Types.sig0, 'a1) Types.dPair -> part Types.sig0 **) +let dpi1__o__sig_to_part__o__inject x2 = + part_from_sig x2.Types.dpi1 + +(** val dpi1__o__sig_to_part__o__part_no__o__inject : + (Nat.nat Types.sig0, 'a1) Types.dPair -> Nat.nat Types.sig0 **) +let dpi1__o__sig_to_part__o__part_no__o__inject x2 = + part_no__o__inject (part_from_sig x2.Types.dpi1) + +(** val dpi1__o__sig_to_part__o__part_no__o__Z_of_nat : + (Nat.nat Types.sig0, 'a1) Types.dPair -> Z.z **) +let dpi1__o__sig_to_part__o__part_no__o__Z_of_nat x1 = + part_no__o__Z_of_nat (part_from_sig x1.Types.dpi1) + +(** val dpi1__o__sig_to_part__o__part_no : + (Nat.nat Types.sig0, 'a1) Types.dPair -> Nat.nat **) +let dpi1__o__sig_to_part__o__part_no x1 = + part_no (part_from_sig x1.Types.dpi1) + +(** val eject__o__sig_to_part__o__inject : + Nat.nat Types.sig0 Types.sig0 -> part Types.sig0 **) +let eject__o__sig_to_part__o__inject x2 = + part_from_sig (Types.pi1 x2) + +(** val eject__o__sig_to_part__o__part_no__o__inject : + Nat.nat Types.sig0 Types.sig0 -> Nat.nat Types.sig0 **) +let eject__o__sig_to_part__o__part_no__o__inject x2 = + part_no__o__inject (part_from_sig (Types.pi1 x2)) + +(** val eject__o__sig_to_part__o__part_no__o__Z_of_nat : + Nat.nat Types.sig0 Types.sig0 -> Z.z **) +let eject__o__sig_to_part__o__part_no__o__Z_of_nat x1 = + part_no__o__Z_of_nat (part_from_sig (Types.pi1 x1)) + +(** val eject__o__sig_to_part__o__part_no : + Nat.nat Types.sig0 Types.sig0 -> Nat.nat **) +let eject__o__sig_to_part__o__part_no x1 = + part_no (part_from_sig (Types.pi1 x1)) + +(** val sig_to_part__o__part_no : Nat.nat Types.sig0 -> Nat.nat **) +let sig_to_part__o__part_no x0 = + part_no (part_from_sig x0) + +(** val sig_to_part__o__part_no__o__Z_of_nat : Nat.nat Types.sig0 -> Z.z **) +let sig_to_part__o__part_no__o__Z_of_nat x0 = + part_no__o__Z_of_nat (part_from_sig x0) + +(** val sig_to_part__o__part_no__o__inject : + Nat.nat Types.sig0 -> Nat.nat Types.sig0 **) +let sig_to_part__o__part_no__o__inject x1 = + part_no__o__inject (part_from_sig x1) + +(** val sig_to_part__o__inject : Nat.nat Types.sig0 -> part Types.sig0 **) +let sig_to_part__o__inject x1 = + part_from_sig x1 + +(** val dpi1__o__part_no__o__inject__o__sig_to_part : + (part, 'a1) Types.dPair -> part **) +let dpi1__o__part_no__o__inject__o__sig_to_part x1 = + part_from_sig (dpi1__o__part_no__o__inject x1) + +(** val eject__o__part_no__o__inject__o__sig_to_part : + part Types.sig0 -> part **) +let eject__o__part_no__o__inject__o__sig_to_part x1 = + part_from_sig (eject__o__part_no__o__inject x1) + +(** val inject__o__sig_to_part : Nat.nat -> part **) +let inject__o__sig_to_part x0 = + part_from_sig x0 + +(** val part_no__o__inject__o__sig_to_part : part -> part **) +let part_no__o__inject__o__sig_to_part x0 = + part_from_sig (part_no__o__inject x0) + +(** val dpi1__o__sig_to_part : + (Nat.nat Types.sig0, 'a1) Types.dPair -> part **) +let dpi1__o__sig_to_part x1 = + part_from_sig x1.Types.dpi1 + +(** val eject__o__sig_to_part : Nat.nat Types.sig0 Types.sig0 -> part **) +let eject__o__sig_to_part x1 = + part_from_sig (Types.pi1 x1) + +type beval = +| BVundef +| BVnonzero +| BVXor of Pointers.pointer Types.option * Pointers.pointer Types.option + * part +| BVByte of BitVector.byte +| BVnull of part +| BVptr of Pointers.pointer * part +| BVpc of program_counter * part + +(** val beval_rect_Type4 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) + -> (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) + -> beval -> 'a1 **) +let rec beval_rect_Type4 h_BVundef h_BVnonzero h_BVXor h_BVByte h_BVnull h_BVptr h_BVpc = function +| BVundef -> h_BVundef +| BVnonzero -> h_BVnonzero +| BVXor (x_6222, x_6221, x_6220) -> h_BVXor x_6222 x_6221 x_6220 +| BVByte x_6223 -> h_BVByte x_6223 +| BVnull x_6224 -> h_BVnull x_6224 +| BVptr (x_6226, x_6225) -> h_BVptr x_6226 x_6225 +| BVpc (x_6228, x_6227) -> h_BVpc x_6228 x_6227 + +(** val beval_rect_Type5 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) + -> (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) + -> beval -> 'a1 **) +let rec beval_rect_Type5 h_BVundef h_BVnonzero h_BVXor h_BVByte h_BVnull h_BVptr h_BVpc = function +| BVundef -> h_BVundef +| BVnonzero -> h_BVnonzero +| BVXor (x_6239, x_6238, x_6237) -> h_BVXor x_6239 x_6238 x_6237 +| BVByte x_6240 -> h_BVByte x_6240 +| BVnull x_6241 -> h_BVnull x_6241 +| BVptr (x_6243, x_6242) -> h_BVptr x_6243 x_6242 +| BVpc (x_6245, x_6244) -> h_BVpc x_6245 x_6244 + +(** val beval_rect_Type3 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) + -> (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) + -> beval -> 'a1 **) +let rec beval_rect_Type3 h_BVundef h_BVnonzero h_BVXor h_BVByte h_BVnull h_BVptr h_BVpc = function +| BVundef -> h_BVundef +| BVnonzero -> h_BVnonzero +| BVXor (x_6256, x_6255, x_6254) -> h_BVXor x_6256 x_6255 x_6254 +| BVByte x_6257 -> h_BVByte x_6257 +| BVnull x_6258 -> h_BVnull x_6258 +| BVptr (x_6260, x_6259) -> h_BVptr x_6260 x_6259 +| BVpc (x_6262, x_6261) -> h_BVpc x_6262 x_6261 + +(** val beval_rect_Type2 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) + -> (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) + -> beval -> 'a1 **) +let rec beval_rect_Type2 h_BVundef h_BVnonzero h_BVXor h_BVByte h_BVnull h_BVptr h_BVpc = function +| BVundef -> h_BVundef +| BVnonzero -> h_BVnonzero +| BVXor (x_6273, x_6272, x_6271) -> h_BVXor x_6273 x_6272 x_6271 +| BVByte x_6274 -> h_BVByte x_6274 +| BVnull x_6275 -> h_BVnull x_6275 +| BVptr (x_6277, x_6276) -> h_BVptr x_6277 x_6276 +| BVpc (x_6279, x_6278) -> h_BVpc x_6279 x_6278 + +(** val beval_rect_Type1 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) + -> (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) + -> beval -> 'a1 **) +let rec beval_rect_Type1 h_BVundef h_BVnonzero h_BVXor h_BVByte h_BVnull h_BVptr h_BVpc = function +| BVundef -> h_BVundef +| BVnonzero -> h_BVnonzero +| BVXor (x_6290, x_6289, x_6288) -> h_BVXor x_6290 x_6289 x_6288 +| BVByte x_6291 -> h_BVByte x_6291 +| BVnull x_6292 -> h_BVnull x_6292 +| BVptr (x_6294, x_6293) -> h_BVptr x_6294 x_6293 +| BVpc (x_6296, x_6295) -> h_BVpc x_6296 x_6295 + +(** val beval_rect_Type0 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) + -> (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) + -> beval -> 'a1 **) +let rec beval_rect_Type0 h_BVundef h_BVnonzero h_BVXor h_BVByte h_BVnull h_BVptr h_BVpc = function +| BVundef -> h_BVundef +| BVnonzero -> h_BVnonzero +| BVXor (x_6307, x_6306, x_6305) -> h_BVXor x_6307 x_6306 x_6305 +| BVByte x_6308 -> h_BVByte x_6308 +| BVnull x_6309 -> h_BVnull x_6309 +| BVptr (x_6311, x_6310) -> h_BVptr x_6311 x_6310 +| BVpc (x_6313, x_6312) -> h_BVpc x_6313 x_6312 + +(** val beval_inv_rect_Type4 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 **) +let beval_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = beval_rect_Type4 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val beval_inv_rect_Type3 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 **) +let beval_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = beval_rect_Type3 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val beval_inv_rect_Type2 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 **) +let beval_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = beval_rect_Type2 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val beval_inv_rect_Type1 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 **) +let beval_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = beval_rect_Type1 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val beval_inv_rect_Type0 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 **) +let beval_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = beval_rect_Type0 h1 h2 h3 h4 h5 h6 h7 hterm in hcut __ + +(** val beval_discr : beval -> beval -> __ **) +let beval_discr x y = + Logic.eq_rect_Type2 x + (match x with + | BVundef -> Obj.magic (fun _ dH -> dH) + | BVnonzero -> Obj.magic (fun _ dH -> dH) + | BVXor (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | BVByte a0 -> Obj.magic (fun _ dH -> dH __) + | BVnull a0 -> Obj.magic (fun _ dH -> dH __) + | BVptr (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | BVpc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val beval_jmdiscr : beval -> beval -> __ **) +let beval_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | BVundef -> Obj.magic (fun _ dH -> dH) + | BVnonzero -> Obj.magic (fun _ dH -> dH) + | BVXor (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | BVByte a0 -> Obj.magic (fun _ dH -> dH __) + | BVnull a0 -> Obj.magic (fun _ dH -> dH __) + | BVptr (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | BVpc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val eq_bv_suffix : + Nat.nat -> Nat.nat -> Nat.nat -> BitVector.bitVector -> + BitVector.bitVector -> Bool.bool **) +let eq_bv_suffix n m p v1 v2 = + let b1 = (Vector.vsplit n p v1).Types.snd in + let b2 = (Vector.vsplit m p v2).Types.snd in BitVector.eq_bv p b1 b2 + +(** val pointer_of_bevals : + beval List.list -> Pointers.pointer Errors.res **) +let pointer_of_bevals = function +| List.Nil -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.CorruptedPointer), + List.Nil)) +| List.Cons (bv1, tl) -> + (match tl with + | List.Nil -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.CorruptedPointer), + List.Nil)) + | List.Cons (bv2, tl') -> + (match tl' with + | List.Nil -> + (match bv1 with + | BVundef -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVByte x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnull x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVptr (ptr1, p1) -> + (match bv2 with + | BVundef -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVByte x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnull x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVptr (ptr2, p2) -> + (match Bool.andb + (Bool.andb + (Bool.andb (Nat.eqb (part_no p1) Nat.O) + (Nat.eqb (part_no p2) (Nat.S Nat.O))) + (Pointers.eq_block ptr1.Pointers.pblock + ptr2.Pointers.pblock)) + (eq_bv_suffix (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Pointers.offv ptr1.Pointers.poff) + (Pointers.offv ptr2.Pointers.poff)) with + | Bool.True -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) ptr2) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil))) + | BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil))) + | BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil))) + | List.Cons (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.CorruptedPointer), + List.Nil)))) + +(** val pc_of_bevals : beval List.list -> program_counter Errors.res **) +let pc_of_bevals = function +| List.Nil -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.CorruptedPointer), + List.Nil)) +| List.Cons (bv1, tl) -> + (match tl with + | List.Nil -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.CorruptedPointer), + List.Nil)) + | List.Cons (bv2, tl') -> + (match tl' with + | List.Nil -> + (match bv1 with + | BVundef -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVByte x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnull x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVpc (ptr1, p1) -> + (match bv2 with + | BVundef -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnonzero -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVByte x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVnull x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVptr (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil)) + | BVpc (ptr2, p2) -> + (match Bool.andb + (Bool.andb (Nat.eqb (part_no p1) Nat.O) + (Nat.eqb (part_no p2) (Nat.S Nat.O))) + (eq_program_counter ptr1 ptr2) with + | Bool.True -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) ptr2) + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.CorruptedPointer), List.Nil))))) + | List.Cons (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.CorruptedPointer), + List.Nil)))) + +(** val bevals_of_pointer : Pointers.pointer -> beval List.list **) +let bevals_of_pointer p = + List.map (fun n_sig -> BVptr (p, (part_from_sig n_sig))) + (Lists.range_strong AST.size_pointer) + +(** val bevals_of_pc : program_counter -> beval List.list **) +let bevals_of_pc p = + List.map (fun n_sig -> BVpc (p, (part_from_sig n_sig))) + (Lists.range_strong AST.size_pointer) + +(** val list_to_pair : 'a1 List.list -> ('a1, 'a1) Types.prod **) +let list_to_pair l = + (match l with + | List.Nil -> + (fun _ -> Obj.magic Nat.nat_discr Nat.O (Nat.S (Nat.S Nat.O)) __) + | List.Cons (a, tl) -> + (match tl with + | List.Nil -> + (fun _ -> + Obj.magic Nat.nat_discr (Nat.S Nat.O) (Nat.S (Nat.S Nat.O)) __ + (fun _ -> Obj.magic Nat.nat_discr Nat.O (Nat.S Nat.O) __)) + | List.Cons (b, tl') -> + (match tl' with + | List.Nil -> (fun _ -> { Types.fst = a; Types.snd = b }) + | List.Cons (c, tl'') -> + (fun _ -> + Obj.magic Nat.nat_discr (Nat.S (Nat.S (Nat.S + (List.length tl'')))) (Nat.S (Nat.S Nat.O)) __ (fun _ -> + Obj.magic Nat.nat_discr (Nat.S (Nat.S (List.length tl''))) + (Nat.S Nat.O) __ (fun _ -> + Obj.magic Nat.nat_discr (Nat.S (List.length tl'')) Nat.O __)))))) + __ + +(** val beval_pair_of_pointer : + Pointers.pointer -> (beval, beval) Types.prod **) +let beval_pair_of_pointer p = + list_to_pair (bevals_of_pointer p) + +(** val beval_pair_of_pc : program_counter -> (beval, beval) Types.prod **) +let beval_pair_of_pc p = + list_to_pair (bevals_of_pc p) + +(** val bool_of_beval : beval -> Bool.bool Errors.res **) +let bool_of_beval = function +| BVundef -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.ValueNotABoolean), + List.Nil)) +| BVnonzero -> Errors.OK Bool.True +| BVXor (x, x0, x1) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.ValueNotABoolean), + List.Nil)) +| BVByte b -> + Errors.OK + (Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) b)) +| BVnull x -> Errors.OK Bool.False +| BVptr (x, x0) -> Errors.OK Bool.True +| BVpc (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.ValueNotABoolean), + List.Nil)) + +(** val byte_of_val : + ErrorMessages.errorMessage -> beval -> BitVector.byte Errors.res **) +let byte_of_val err = function +| BVundef -> Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) +| BVnonzero -> Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) +| BVXor (x, x0, x1) -> Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) +| BVByte b0 -> Errors.OK b0 +| BVnull x -> Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) +| BVptr (x, x0) -> Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) +| BVpc (x, x0) -> Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) + +(** val word_of_list_beval : beval List.list -> Integers.int Errors.res **) +let word_of_list_beval l = + let first_byte = fun l0 -> + match l0 with + | List.Nil -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.NotAnInt32Val), List.Nil))) + | List.Cons (hd, tl) -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (byte_of_val ErrorMessages.NotAnInt32Val hd)) (fun b -> + Obj.magic (Errors.OK { Types.fst = b; Types.snd = tl })) + in + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) (first_byte l) (fun b1 l0 -> + Monad.m_bind2 (Monad.max_def Errors.res0) (first_byte l0) (fun b2 l1 -> + Monad.m_bind2 (Monad.max_def Errors.res0) (first_byte l1) + (fun b3 l2 -> + Monad.m_bind2 (Monad.max_def Errors.res0) (first_byte l2) + (fun b4 l3 -> + match l3 with + | List.Nil -> + Obj.magic (Errors.OK + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) b4 + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) b3 + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) b2 b1)))) + | List.Cons (x, x0) -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.NotAnInt32Val), List.Nil)))))))) + +type add_or_sub = +| Do_add +| Do_sub + +(** val add_or_sub_rect_Type4 : 'a1 -> 'a1 -> add_or_sub -> 'a1 **) +let rec add_or_sub_rect_Type4 h_do_add h_do_sub = function +| Do_add -> h_do_add +| Do_sub -> h_do_sub + +(** val add_or_sub_rect_Type5 : 'a1 -> 'a1 -> add_or_sub -> 'a1 **) +let rec add_or_sub_rect_Type5 h_do_add h_do_sub = function +| Do_add -> h_do_add +| Do_sub -> h_do_sub + +(** val add_or_sub_rect_Type3 : 'a1 -> 'a1 -> add_or_sub -> 'a1 **) +let rec add_or_sub_rect_Type3 h_do_add h_do_sub = function +| Do_add -> h_do_add +| Do_sub -> h_do_sub + +(** val add_or_sub_rect_Type2 : 'a1 -> 'a1 -> add_or_sub -> 'a1 **) +let rec add_or_sub_rect_Type2 h_do_add h_do_sub = function +| Do_add -> h_do_add +| Do_sub -> h_do_sub + +(** val add_or_sub_rect_Type1 : 'a1 -> 'a1 -> add_or_sub -> 'a1 **) +let rec add_or_sub_rect_Type1 h_do_add h_do_sub = function +| Do_add -> h_do_add +| Do_sub -> h_do_sub + +(** val add_or_sub_rect_Type0 : 'a1 -> 'a1 -> add_or_sub -> 'a1 **) +let rec add_or_sub_rect_Type0 h_do_add h_do_sub = function +| Do_add -> h_do_add +| Do_sub -> h_do_sub + +(** val add_or_sub_inv_rect_Type4 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let add_or_sub_inv_rect_Type4 hterm h1 h2 = + let hcut = add_or_sub_rect_Type4 h1 h2 hterm in hcut __ + +(** val add_or_sub_inv_rect_Type3 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let add_or_sub_inv_rect_Type3 hterm h1 h2 = + let hcut = add_or_sub_rect_Type3 h1 h2 hterm in hcut __ + +(** val add_or_sub_inv_rect_Type2 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let add_or_sub_inv_rect_Type2 hterm h1 h2 = + let hcut = add_or_sub_rect_Type2 h1 h2 hterm in hcut __ + +(** val add_or_sub_inv_rect_Type1 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let add_or_sub_inv_rect_Type1 hterm h1 h2 = + let hcut = add_or_sub_rect_Type1 h1 h2 hterm in hcut __ + +(** val add_or_sub_inv_rect_Type0 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let add_or_sub_inv_rect_Type0 hterm h1 h2 = + let hcut = add_or_sub_rect_Type0 h1 h2 hterm in hcut __ + +(** val add_or_sub_discr : add_or_sub -> add_or_sub -> __ **) +let add_or_sub_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Do_add -> Obj.magic (fun _ dH -> dH) + | Do_sub -> Obj.magic (fun _ dH -> dH)) y + +(** val add_or_sub_jmdiscr : add_or_sub -> add_or_sub -> __ **) +let add_or_sub_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Do_add -> Obj.magic (fun _ dH -> dH) + | Do_sub -> Obj.magic (fun _ dH -> dH)) y + +(** val eq_add_or_sub : add_or_sub -> add_or_sub -> Bool.bool **) +let eq_add_or_sub x y = + match x with + | Do_add -> + (match y with + | Do_add -> Bool.True + | Do_sub -> Bool.False) + | Do_sub -> + (match y with + | Do_add -> Bool.False + | Do_sub -> Bool.True) + +type bebit = +| BBbit of Bool.bool +| BBundef +| BBptrcarry of add_or_sub * Pointers.pointer * part * BitVector.bitVector + +(** val bebit_rect_Type4 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 **) +let rec bebit_rect_Type4 h_BBbit h_BBundef h_BBptrcarry = function +| BBbit x_6471 -> h_BBbit x_6471 +| BBundef -> h_BBundef +| BBptrcarry (x_6474, x_6473, p, x_6472) -> + h_BBptrcarry x_6474 x_6473 p x_6472 + +(** val bebit_rect_Type5 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 **) +let rec bebit_rect_Type5 h_BBbit h_BBundef h_BBptrcarry = function +| BBbit x_6479 -> h_BBbit x_6479 +| BBundef -> h_BBundef +| BBptrcarry (x_6482, x_6481, p, x_6480) -> + h_BBptrcarry x_6482 x_6481 p x_6480 + +(** val bebit_rect_Type3 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 **) +let rec bebit_rect_Type3 h_BBbit h_BBundef h_BBptrcarry = function +| BBbit x_6487 -> h_BBbit x_6487 +| BBundef -> h_BBundef +| BBptrcarry (x_6490, x_6489, p, x_6488) -> + h_BBptrcarry x_6490 x_6489 p x_6488 + +(** val bebit_rect_Type2 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 **) +let rec bebit_rect_Type2 h_BBbit h_BBundef h_BBptrcarry = function +| BBbit x_6495 -> h_BBbit x_6495 +| BBundef -> h_BBundef +| BBptrcarry (x_6498, x_6497, p, x_6496) -> + h_BBptrcarry x_6498 x_6497 p x_6496 + +(** val bebit_rect_Type1 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 **) +let rec bebit_rect_Type1 h_BBbit h_BBundef h_BBptrcarry = function +| BBbit x_6503 -> h_BBbit x_6503 +| BBundef -> h_BBundef +| BBptrcarry (x_6506, x_6505, p, x_6504) -> + h_BBptrcarry x_6506 x_6505 p x_6504 + +(** val bebit_rect_Type0 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 **) +let rec bebit_rect_Type0 h_BBbit h_BBundef h_BBptrcarry = function +| BBbit x_6511 -> h_BBbit x_6511 +| BBundef -> h_BBundef +| BBptrcarry (x_6514, x_6513, p, x_6512) -> + h_BBptrcarry x_6514 x_6513 p x_6512 + +(** val bebit_inv_rect_Type4 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let bebit_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = bebit_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val bebit_inv_rect_Type3 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let bebit_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = bebit_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val bebit_inv_rect_Type2 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let bebit_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = bebit_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val bebit_inv_rect_Type1 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let bebit_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = bebit_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val bebit_inv_rect_Type0 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let bebit_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = bebit_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val bebit_discr : bebit -> bebit -> __ **) +let bebit_discr x y = + Logic.eq_rect_Type2 x + (match x with + | BBbit a0 -> Obj.magic (fun _ dH -> dH __) + | BBundef -> Obj.magic (fun _ dH -> dH) + | BBptrcarry (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) + y + +(** val bebit_jmdiscr : bebit -> bebit -> __ **) +let bebit_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | BBbit a0 -> Obj.magic (fun _ dH -> dH __) + | BBundef -> Obj.magic (fun _ dH -> dH) + | BBptrcarry (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) + y + +(** val bit_of_val : + ErrorMessages.errorMessage -> bebit -> BitVector.bit Errors.res **) +let bit_of_val err = function +| BBbit b0 -> Errors.OK b0 +| BBundef -> Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) +| BBptrcarry (x, x0, x1, x2) -> + Errors.Error (List.Cons ((Errors.MSG err), List.Nil)) + diff --git a/extracted/byteValues.mli b/extracted/byteValues.mli new file mode 100644 index 0000000..ad47b2e --- /dev/null +++ b/extracted/byteValues.mli @@ -0,0 +1,484 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open Hide + +type cpointer = Pointers.pointer Types.sig0 + +type xpointer = Pointers.pointer Types.sig0 + +type program_counter = { pc_block : Pointers.block Types.sig0; + pc_offset : Positive.pos } + +val program_counter_rect_Type4 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 + +val program_counter_rect_Type5 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 + +val program_counter_rect_Type3 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 + +val program_counter_rect_Type2 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 + +val program_counter_rect_Type1 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 + +val program_counter_rect_Type0 : + (Pointers.block Types.sig0 -> Positive.pos -> 'a1) -> program_counter -> + 'a1 + +val pc_block : program_counter -> Pointers.block Types.sig0 + +val pc_offset : program_counter -> Positive.pos + +val program_counter_inv_rect_Type4 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> 'a1) + -> 'a1 + +val program_counter_inv_rect_Type3 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> 'a1) + -> 'a1 + +val program_counter_inv_rect_Type2 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> 'a1) + -> 'a1 + +val program_counter_inv_rect_Type1 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> 'a1) + -> 'a1 + +val program_counter_inv_rect_Type0 : + program_counter -> (Pointers.block Types.sig0 -> Positive.pos -> __ -> 'a1) + -> 'a1 + +val program_counter_discr : program_counter -> program_counter -> __ + +val program_counter_jmdiscr : program_counter -> program_counter -> __ + +val eq_program_counter : program_counter -> program_counter -> Bool.bool + +val bitvector_from_pos : Nat.nat -> Positive.pos -> BitVector.bitVector + +val pos_from_bitvector : Nat.nat -> BitVector.bitVector -> Positive.pos + +val cpointer_of_pc : program_counter -> cpointer Types.option + +type part = + Nat.nat + (* singleton inductive, whose constructor was mk_part *) + +val part_rect_Type4 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 + +val part_rect_Type5 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 + +val part_rect_Type3 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 + +val part_rect_Type2 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 + +val part_rect_Type1 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 + +val part_rect_Type0 : (Nat.nat -> __ -> 'a1) -> part -> 'a1 + +val part_no : part -> Nat.nat + +val part_inv_rect_Type4 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val part_inv_rect_Type3 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val part_inv_rect_Type2 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val part_inv_rect_Type1 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val part_inv_rect_Type0 : part -> (Nat.nat -> __ -> __ -> 'a1) -> 'a1 + +val part_discr : part -> part -> __ + +val part_jmdiscr : part -> part -> __ + +val dpi1__o__part_no__o__inject : + (part, 'a1) Types.dPair -> Nat.nat Types.sig0 + +val dpi1__o__part_no__o__Z_of_nat : (part, 'a1) Types.dPair -> Z.z + +val eject__o__part_no__o__inject : part Types.sig0 -> Nat.nat Types.sig0 + +val eject__o__part_no__o__Z_of_nat : part Types.sig0 -> Z.z + +val part_no__o__Z_of_nat : part -> Z.z + +val part_no__o__inject : part -> Nat.nat Types.sig0 + +val dpi1__o__part_no : (part, 'a1) Types.dPair -> Nat.nat + +val eject__o__part_no : part Types.sig0 -> Nat.nat + +val part_from_sig : Nat.nat Types.sig0 -> part + +val dpi1__o__part_no__o__inject__o__sig_to_part__o__inject : + (part, 'a1) Types.dPair -> part Types.sig0 + +val dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no__o__inject : + (part, 'a1) Types.dPair -> Nat.nat Types.sig0 + +val dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat : + (part, 'a1) Types.dPair -> Z.z + +val dpi1__o__part_no__o__inject__o__sig_to_part__o__part_no : + (part, 'a1) Types.dPair -> Nat.nat + +val eject__o__part_no__o__inject__o__sig_to_part__o__inject : + part Types.sig0 -> part Types.sig0 + +val eject__o__part_no__o__inject__o__sig_to_part__o__part_no__o__inject : + part Types.sig0 -> Nat.nat Types.sig0 + +val eject__o__part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat : + part Types.sig0 -> Z.z + +val eject__o__part_no__o__inject__o__sig_to_part__o__part_no : + part Types.sig0 -> Nat.nat + +val inject__o__sig_to_part__o__inject : Nat.nat -> part Types.sig0 + +val inject__o__sig_to_part__o__part_no__o__inject : + Nat.nat -> Nat.nat Types.sig0 + +val inject__o__sig_to_part__o__part_no__o__Z_of_nat : Nat.nat -> Z.z + +val inject__o__sig_to_part__o__part_no : Nat.nat -> Nat.nat + +val part_no__o__inject__o__sig_to_part__o__inject : part -> part Types.sig0 + +val part_no__o__inject__o__sig_to_part__o__part_no__o__inject : + part -> Nat.nat Types.sig0 + +val part_no__o__inject__o__sig_to_part__o__part_no__o__Z_of_nat : part -> Z.z + +val part_no__o__inject__o__sig_to_part__o__part_no : part -> Nat.nat + +val dpi1__o__sig_to_part__o__inject : + (Nat.nat Types.sig0, 'a1) Types.dPair -> part Types.sig0 + +val dpi1__o__sig_to_part__o__part_no__o__inject : + (Nat.nat Types.sig0, 'a1) Types.dPair -> Nat.nat Types.sig0 + +val dpi1__o__sig_to_part__o__part_no__o__Z_of_nat : + (Nat.nat Types.sig0, 'a1) Types.dPair -> Z.z + +val dpi1__o__sig_to_part__o__part_no : + (Nat.nat Types.sig0, 'a1) Types.dPair -> Nat.nat + +val eject__o__sig_to_part__o__inject : + Nat.nat Types.sig0 Types.sig0 -> part Types.sig0 + +val eject__o__sig_to_part__o__part_no__o__inject : + Nat.nat Types.sig0 Types.sig0 -> Nat.nat Types.sig0 + +val eject__o__sig_to_part__o__part_no__o__Z_of_nat : + Nat.nat Types.sig0 Types.sig0 -> Z.z + +val eject__o__sig_to_part__o__part_no : + Nat.nat Types.sig0 Types.sig0 -> Nat.nat + +val sig_to_part__o__part_no : Nat.nat Types.sig0 -> Nat.nat + +val sig_to_part__o__part_no__o__Z_of_nat : Nat.nat Types.sig0 -> Z.z + +val sig_to_part__o__part_no__o__inject : + Nat.nat Types.sig0 -> Nat.nat Types.sig0 + +val sig_to_part__o__inject : Nat.nat Types.sig0 -> part Types.sig0 + +val dpi1__o__part_no__o__inject__o__sig_to_part : + (part, 'a1) Types.dPair -> part + +val eject__o__part_no__o__inject__o__sig_to_part : part Types.sig0 -> part + +val inject__o__sig_to_part : Nat.nat -> part + +val part_no__o__inject__o__sig_to_part : part -> part + +val dpi1__o__sig_to_part : (Nat.nat Types.sig0, 'a1) Types.dPair -> part + +val eject__o__sig_to_part : Nat.nat Types.sig0 Types.sig0 -> part + +type beval = +| BVundef +| BVnonzero +| BVXor of Pointers.pointer Types.option * Pointers.pointer Types.option + * part +| BVByte of BitVector.byte +| BVnull of part +| BVptr of Pointers.pointer * part +| BVpc of program_counter * part + +val beval_rect_Type4 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) -> + (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) -> + beval -> 'a1 + +val beval_rect_Type5 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) -> + (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) -> + beval -> 'a1 + +val beval_rect_Type3 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) -> + (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) -> + beval -> 'a1 + +val beval_rect_Type2 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) -> + (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) -> + beval -> 'a1 + +val beval_rect_Type1 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) -> + (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) -> + beval -> 'a1 + +val beval_rect_Type0 : + 'a1 -> 'a1 -> (Pointers.pointer Types.option -> Pointers.pointer + Types.option -> part -> 'a1) -> (BitVector.byte -> 'a1) -> (part -> 'a1) -> + (Pointers.pointer -> part -> 'a1) -> (program_counter -> part -> 'a1) -> + beval -> 'a1 + +val beval_inv_rect_Type4 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 + +val beval_inv_rect_Type3 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 + +val beval_inv_rect_Type2 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 + +val beval_inv_rect_Type1 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 + +val beval_inv_rect_Type0 : + beval -> (__ -> 'a1) -> (__ -> 'a1) -> (Pointers.pointer Types.option -> + Pointers.pointer Types.option -> part -> __ -> 'a1) -> (BitVector.byte -> + __ -> 'a1) -> (part -> __ -> 'a1) -> (Pointers.pointer -> part -> __ -> + 'a1) -> (program_counter -> part -> __ -> 'a1) -> 'a1 + +val beval_discr : beval -> beval -> __ + +val beval_jmdiscr : beval -> beval -> __ + +val eq_bv_suffix : + Nat.nat -> Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + -> Bool.bool + +val pointer_of_bevals : beval List.list -> Pointers.pointer Errors.res + +val pc_of_bevals : beval List.list -> program_counter Errors.res + +val bevals_of_pointer : Pointers.pointer -> beval List.list + +val bevals_of_pc : program_counter -> beval List.list + +val list_to_pair : 'a1 List.list -> ('a1, 'a1) Types.prod + +val beval_pair_of_pointer : Pointers.pointer -> (beval, beval) Types.prod + +val beval_pair_of_pc : program_counter -> (beval, beval) Types.prod + +val bool_of_beval : beval -> Bool.bool Errors.res + +val byte_of_val : + ErrorMessages.errorMessage -> beval -> BitVector.byte Errors.res + +val word_of_list_beval : beval List.list -> Integers.int Errors.res + +type add_or_sub = +| Do_add +| Do_sub + +val add_or_sub_rect_Type4 : 'a1 -> 'a1 -> add_or_sub -> 'a1 + +val add_or_sub_rect_Type5 : 'a1 -> 'a1 -> add_or_sub -> 'a1 + +val add_or_sub_rect_Type3 : 'a1 -> 'a1 -> add_or_sub -> 'a1 + +val add_or_sub_rect_Type2 : 'a1 -> 'a1 -> add_or_sub -> 'a1 + +val add_or_sub_rect_Type1 : 'a1 -> 'a1 -> add_or_sub -> 'a1 + +val add_or_sub_rect_Type0 : 'a1 -> 'a1 -> add_or_sub -> 'a1 + +val add_or_sub_inv_rect_Type4 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val add_or_sub_inv_rect_Type3 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val add_or_sub_inv_rect_Type2 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val add_or_sub_inv_rect_Type1 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val add_or_sub_inv_rect_Type0 : + add_or_sub -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val add_or_sub_discr : add_or_sub -> add_or_sub -> __ + +val add_or_sub_jmdiscr : add_or_sub -> add_or_sub -> __ + +val eq_add_or_sub : add_or_sub -> add_or_sub -> Bool.bool + +type bebit = +| BBbit of Bool.bool +| BBundef +| BBptrcarry of add_or_sub * Pointers.pointer * part * BitVector.bitVector + +val bebit_rect_Type4 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 + +val bebit_rect_Type5 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 + +val bebit_rect_Type3 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 + +val bebit_rect_Type2 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 + +val bebit_rect_Type1 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 + +val bebit_rect_Type0 : + (Bool.bool -> 'a1) -> 'a1 -> (add_or_sub -> Pointers.pointer -> part -> + BitVector.bitVector -> 'a1) -> bebit -> 'a1 + +val bebit_inv_rect_Type4 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val bebit_inv_rect_Type3 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val bebit_inv_rect_Type2 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val bebit_inv_rect_Type1 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val bebit_inv_rect_Type0 : + bebit -> (Bool.bool -> __ -> 'a1) -> (__ -> 'a1) -> (add_or_sub -> + Pointers.pointer -> part -> BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val bebit_discr : bebit -> bebit -> __ + +val bebit_jmdiscr : bebit -> bebit -> __ + +val bit_of_val : + ErrorMessages.errorMessage -> bebit -> BitVector.bit Errors.res + diff --git a/extracted/casts.ml b/extracted/casts.ml new file mode 100644 index 0000000..cfe0dfe --- /dev/null +++ b/extracted/casts.ml @@ -0,0 +1,92 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +(** val truncate : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let truncate m n x = + (Vector.vsplit m n x).Types.snd + +(** val sign : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let sign m n v = + Vector.pad_vector (Arithmetic.sign_bit m v) n m v + diff --git a/extracted/casts.mli b/extracted/casts.mli new file mode 100644 index 0000000..4fc14ee --- /dev/null +++ b/extracted/casts.mli @@ -0,0 +1,87 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +val truncate : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val sign : Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + diff --git a/extracted/cexec.ml b/extracted/cexec.ml new file mode 100644 index 0000000..199f1a9 --- /dev/null +++ b/extracted/cexec.ml @@ -0,0 +1,1189 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open IO + +open SmallstepExec + +open TypeComparison + +open ClassifyOp + +open Smallstep + +open Csyntax + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +(** val exec_bool_of_val : + Values.val0 -> Csyntax.type0 -> Bool.bool Errors.res **) +let exec_bool_of_val v ty = + match v with + | Values.Vundef -> + Errors.Error (Errors.msg ErrorMessages.ValueIsNotABoolean) + | Values.Vint (sz, i) -> + (match ty with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz', x) -> + AST.intsize_eq_elim sz sz' i (fun i0 -> Errors.OK + (Bool.notb + (BitVector.eq_bv (AST.bitsize_of_intsize sz') i0 + (BitVector.zero (AST.bitsize_of_intsize sz'))))) (Errors.Error + (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vnull -> + (match ty with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tpointer x -> Errors.OK Bool.False + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vptr x -> + (match ty with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tpointer x0 -> Errors.OK Bool.True + | Csyntax.Tarray (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tfunction (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x0 -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + +(** val try_cast_null : + GenMem.mem -> AST.intsize -> BitVector.bitVector -> Csyntax.type0 -> + Csyntax.type0 -> Values.val0 Errors.res **) +let try_cast_null m sz i ty ty' = + match BitVector.eq_bv (AST.bitsize_of_intsize sz) i + (BitVector.zero (AST.bitsize_of_intsize sz)) with + | Bool.True -> + (match ty with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tint (sz', x) -> + (match AST.eq_intsize sz sz' with + | Bool.True -> + (match ty' with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tint (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tpointer x0 -> Errors.OK Values.Vnull + | Csyntax.Tarray (x0, x1) -> Errors.OK Values.Vnull + | Csyntax.Tfunction (x0, x1) -> Errors.OK Values.Vnull + | Csyntax.Tstruct (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tunion (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tcomp_ptr x0 -> + Errors.Error (Errors.msg ErrorMessages.BadCast)) + | Bool.False -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tpointer x -> Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tcomp_ptr x -> Errors.Error (Errors.msg ErrorMessages.BadCast)) + | Bool.False -> Errors.Error (Errors.msg ErrorMessages.BadCast) + +(** val ptr_like_type : Csyntax.type0 -> Bool.bool **) +let ptr_like_type = function +| Csyntax.Tvoid -> Bool.False +| Csyntax.Tint (x, x0) -> Bool.False +| Csyntax.Tpointer x -> Bool.True +| Csyntax.Tarray (x, x0) -> Bool.True +| Csyntax.Tfunction (x, x0) -> Bool.True +| Csyntax.Tstruct (x, x0) -> Bool.False +| Csyntax.Tunion (x, x0) -> Bool.False +| Csyntax.Tcomp_ptr x -> Bool.False + +(** val exec_cast : + GenMem.mem -> Values.val0 -> Csyntax.type0 -> Csyntax.type0 -> + Values.val0 Errors.res **) +let exec_cast m v ty ty' = + match v with + | Values.Vundef -> Errors.Error (Errors.msg ErrorMessages.BadCast) + | Values.Vint (sz, i) -> + (match ty with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz1, si1) -> + AST.intsize_eq_elim sz sz1 i (fun i0 -> + match ty' with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tint (sz2, si2) -> + Errors.OK (Values.Vint (sz2, (Csem.cast_int_int sz1 si1 sz2 i0))) + | Csyntax.Tpointer x -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (try_cast_null m sz1 i0 ty ty')) (fun r -> + Obj.magic (Errors.OK r))) + | Csyntax.Tarray (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (try_cast_null m sz1 i0 ty ty')) (fun r -> + Obj.magic (Errors.OK r))) + | Csyntax.Tfunction (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (try_cast_null m sz1 i0 ty ty')) (fun r -> + Obj.magic (Errors.OK r))) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadCast) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.BadCast)) (Errors.Error + (Errors.msg ErrorMessages.BadCast)) + | Csyntax.Tpointer x -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (try_cast_null m sz i ty ty')) (fun r -> + Obj.magic (Errors.OK r))) + | Csyntax.Tarray (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (try_cast_null m sz i ty ty')) (fun r -> + Obj.magic (Errors.OK r))) + | Csyntax.Tfunction (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (try_cast_null m sz i ty ty')) (fun r -> + Obj.magic (Errors.OK r))) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vnull -> + (match Bool.andb (ptr_like_type ty) (ptr_like_type ty') with + | Bool.True -> Errors.OK Values.Vnull + | Bool.False -> Errors.Error (Errors.msg ErrorMessages.BadCast)) + | Values.Vptr ptr -> + (match Bool.andb (ptr_like_type ty) (ptr_like_type ty') with + | Bool.True -> Errors.OK (Values.Vptr ptr) + | Bool.False -> Errors.Error (Errors.msg ErrorMessages.BadCast)) + +(** val load_value_of_type' : + Csyntax.type0 -> GenMem.mem -> (Pointers.block, Pointers.offset) + Types.prod -> Values.val0 Types.option **) +let load_value_of_type' ty m l = + let { Types.fst = loc; Types.snd = ofs } = l in + Csem.load_value_of_type ty m loc ofs + +(** val exec_expr : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr -> (Values.val0, + Events.trace) Types.prod Errors.res **) +let rec exec_expr ge en m = function +| Csyntax.Expr (e', ty) -> + (match e' with + | Csyntax.Econst_int (sz, i) -> + (match ty with + | Csyntax.Tvoid -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tint (sz', x) -> + (match AST.eq_intsize sz sz' with + | Bool.True -> + Errors.OK { Types.fst = (Values.Vint (sz, i)); Types.snd = + Events.e0 } + | Bool.False -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Evar x -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_lvalue' ge en m e' ty)) (fun l tr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (load_value_of_type' ty m l))) (fun v -> + Obj.magic (Errors.OK { Types.fst = v; Types.snd = tr })))) + | Csyntax.Ederef x -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_lvalue' ge en m e' ty)) (fun l tr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (load_value_of_type' ty m l))) (fun v -> + Obj.magic (Errors.OK { Types.fst = v; Types.snd = tr })))) + | Csyntax.Eaddrof a -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_lvalue ge en m a)) (fun lo tr -> + match ty with + | Csyntax.Tvoid -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Tint (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Tpointer x -> + let { Types.fst = loc; Types.snd = ofs } = lo in + Obj.magic (Errors.OK { Types.fst = (Values.Vptr + { Pointers.pblock = loc; Pointers.poff = ofs }); Types.snd = + tr }) + | Csyntax.Tarray (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Tfunction (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Tstruct (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Tunion (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Tcomp_ptr x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)))) + | Csyntax.Eunop (op, a) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a)) (fun v1 tr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (Csem.sem_unary_operation op v1 (Csyntax.typeof a)))) + (fun v -> Obj.magic (Errors.OK { Types.fst = v; Types.snd = tr })))) + | Csyntax.Ebinop (op, a1, a2) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a1)) (fun v1 tr1 -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a2)) (fun v2 tr2 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (Csem.sem_binary_operation op v1 (Csyntax.typeof a1) v2 + (Csyntax.typeof a2) m ty))) (fun v -> + Obj.magic (Errors.OK { Types.fst = v; Types.snd = + (Events.eapp tr1 tr2) }))))) + | Csyntax.Ecast (ty', a) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a)) (fun v tr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (exec_cast m v (Csyntax.typeof a) ty')) (fun v' -> + Obj.magic (Errors.OK { Types.fst = v'; Types.snd = tr })))) + | Csyntax.Econdition (a1, a2, a3) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a1)) (fun v tr1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (exec_bool_of_val v (Csyntax.typeof a1))) (fun b -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (match b with + | Bool.True -> Obj.magic (exec_expr ge en m a2) + | Bool.False -> Obj.magic (exec_expr ge en m a3)) + (fun v' tr2 -> + Obj.magic (Errors.OK { Types.fst = v'; Types.snd = + (Events.eapp tr1 tr2) }))))) + | Csyntax.Eandbool (a1, a2) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a1)) (fun v1 tr1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (exec_bool_of_val v1 (Csyntax.typeof a1))) (fun b1 -> + match b1 with + | Bool.True -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a2)) (fun v2 tr2 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (exec_bool_of_val v2 (Csyntax.typeof a2))) + (fun b2 -> + match Csem.cast_bool_to_target ty (Types.Some + (Values.of_bool b2)) with + | Types.None -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Types.Some v20 -> + Obj.magic (Errors.OK { Types.fst = v20; Types.snd = + (Events.eapp tr1 tr2) }))) + | Bool.False -> + (match Csem.cast_bool_to_target ty (Types.Some Values.vfalse) with + | Types.None -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Types.Some vfls -> + Obj.magic (Errors.OK { Types.fst = vfls; Types.snd = tr1 }))))) + | Csyntax.Eorbool (a1, a2) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a1)) (fun v1 tr1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (exec_bool_of_val v1 (Csyntax.typeof a1))) (fun b1 -> + match b1 with + | Bool.True -> + (match Csem.cast_bool_to_target ty (Types.Some Values.vtrue) with + | Types.None -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Types.Some vtr -> + Obj.magic (Errors.OK { Types.fst = vtr; Types.snd = tr1 })) + | Bool.False -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a2)) (fun v2 tr2 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (exec_bool_of_val v2 (Csyntax.typeof a2))) + (fun b2 -> + match Csem.cast_bool_to_target ty (Types.Some + (Values.of_bool b2)) with + | Types.None -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Types.Some v20 -> + Obj.magic (Errors.OK { Types.fst = v20; Types.snd = + (Events.eapp tr1 tr2) })))))) + | Csyntax.Esizeof ty' -> + (match ty with + | Csyntax.Tvoid -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tint (sz, x) -> + Errors.OK { Types.fst = (Values.Vint (sz, + (AST.repr sz (Csyntax.sizeof ty')))); Types.snd = Events.e0 } + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Efield (x, x0) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_lvalue' ge en m e' ty)) (fun l tr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (load_value_of_type' ty m l))) (fun v -> + Obj.magic (Errors.OK { Types.fst = v; Types.snd = tr })))) + | Csyntax.Ecost (l, a) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a)) (fun v tr -> + Obj.magic (Errors.OK { Types.fst = v; Types.snd = + (Events.eapp (Events.echarge l) tr) })))) +(** val exec_lvalue' : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr_descr -> + Csyntax.type0 -> ((Pointers.block, Pointers.offset) Types.prod, + Events.trace) Types.prod Errors.res **) +and exec_lvalue' ge en m e' ty = + match e' with + | Csyntax.Econst_int (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Evar id -> + (match Identifiers.lookup PreIdentifiers.SymbolTag en id with + | Types.None -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.UnknownIdentifier), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Globalenvs.find_symbol ge id))) (fun l -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = l; Types.snd = + Pointers.zero_offset }; Types.snd = Events.e0 }))) + | Types.Some loc -> + Errors.OK { Types.fst = { Types.fst = loc; Types.snd = + Pointers.zero_offset }; Types.snd = Events.e0 }) + | Csyntax.Ederef a -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge en m a)) (fun v tr -> + match v with + | Values.Vundef -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vint (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vnull -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vptr ptr -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = + ptr.Pointers.pblock; Types.snd = ptr.Pointers.poff }; Types.snd = + tr }))) + | Csyntax.Eaddrof x -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Eunop (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Ebinop (x, x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Ecast (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Econdition (x, x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Eandbool (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Eorbool (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Esizeof x -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) + | Csyntax.Efield (a, i) -> + (match Csyntax.typeof a with + | Csyntax.Tvoid -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tint (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm) + | Csyntax.Tstruct (id, fList) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_lvalue ge en m a)) (fun lofs tr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Csyntax.field_offset i fList)) (fun delta -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = lofs.Types.fst; + Types.snd = + (Pointers.shift_offset (AST.bitsize_of_intsize AST.I16) + lofs.Types.snd (AST.repr AST.I16 delta)) }; Types.snd = + tr })))) + | Csyntax.Tunion (id, fList) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_lvalue ge en m a)) (fun lofs tr -> + Obj.magic (Errors.OK { Types.fst = lofs; Types.snd = tr }))) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedTerm)) + | Csyntax.Ecost (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalueTerm) +(** val exec_lvalue : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr -> ((Pointers.block, + Pointers.offset) Types.prod, Events.trace) Types.prod Errors.res **) +and exec_lvalue ge en m = function +| Csyntax.Expr (e', ty) -> exec_lvalue' ge en m e' ty + +(** val exec_exprlist : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr List.list -> + (Values.val0 List.list, Events.trace) Types.prod Errors.res **) +let rec exec_exprlist ge e m = function +| List.Nil -> Errors.OK { Types.fst = List.Nil; Types.snd = Events.e0 } +| List.Cons (e1, es) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_expr ge e m e1)) (fun v tr1 -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_exprlist ge e m es)) (fun vs tr2 -> + Obj.magic (Errors.OK { Types.fst = (List.Cons (v, vs)); Types.snd = + (Events.eapp tr1 tr2) })))) + +(** val exec_alloc_variables : + Csem.env -> GenMem.mem -> (AST.ident, Csyntax.type0) Types.prod List.list + -> (Csem.env, GenMem.mem) Types.prod **) +let rec exec_alloc_variables en m = function +| List.Nil -> { Types.fst = en; Types.snd = m } +| List.Cons (h, vars) -> + let { Types.fst = id; Types.snd = ty } = h in + let { Types.fst = m1; Types.snd = b1 } = + GenMem.alloc m (Z.z_of_nat Nat.O) (Z.z_of_nat (Csyntax.sizeof ty)) + in + exec_alloc_variables (Identifiers.add PreIdentifiers.SymbolTag en id b1) m1 + vars + +(** val exec_bind_parameters : + Csem.env -> GenMem.mem -> (AST.ident, Csyntax.type0) Types.prod List.list + -> Values.val0 List.list -> GenMem.mem Errors.res **) +let rec exec_bind_parameters e m params vs = + match params with + | List.Nil -> + (match vs with + | List.Nil -> Errors.OK m + | List.Cons (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.WrongNumberOfParameters)) + | List.Cons (idty, params') -> + let { Types.fst = id; Types.snd = ty } = idty in + (match vs with + | List.Nil -> + Errors.Error (Errors.msg ErrorMessages.WrongNumberOfParameters) + | List.Cons (v1, vl) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.UnknownIdentifier), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Identifiers.lookup PreIdentifiers.SymbolTag e id))) (fun b -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.FailedStore), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Csem.store_value_of_type ty m b Pointers.zero_offset v1))) + (fun m1 -> Obj.magic (exec_bind_parameters e m1 params' vl))))) + +(** val is_is_call_cont : Csem.cont -> (__, __) Types.sum **) +let rec is_is_call_cont = function +| Csem.Kstop -> Types.Inl __ +| Csem.Kseq (x, x0) -> Types.Inr __ +| Csem.Kwhile (x, x0, x1) -> Types.Inr __ +| Csem.Kdowhile (x, x0, x1) -> Types.Inr __ +| Csem.Kfor2 (x, x0, x1, x2) -> Types.Inr __ +| Csem.Kfor3 (x, x0, x1, x2) -> Types.Inr __ +| Csem.Kswitch x -> Types.Inr __ +| Csem.Kcall (x, x0, x1, x2) -> Types.Inl __ + +(** val is_Sskip : Csyntax.statement -> (__, __) Types.sum **) +let is_Sskip = function +| Csyntax.Sskip -> Types.Inl __ +| Csyntax.Sassign (x, x0) -> Types.Inr __ +| Csyntax.Scall (x, x0, x1) -> Types.Inr __ +| Csyntax.Ssequence (x, x0) -> Types.Inr __ +| Csyntax.Sifthenelse (x, x0, x1) -> Types.Inr __ +| Csyntax.Swhile (x, x0) -> Types.Inr __ +| Csyntax.Sdowhile (x, x0) -> Types.Inr __ +| Csyntax.Sfor (x, x0, x1, x2) -> Types.Inr __ +| Csyntax.Sbreak -> Types.Inr __ +| Csyntax.Scontinue -> Types.Inr __ +| Csyntax.Sreturn x -> Types.Inr __ +| Csyntax.Sswitch (x, x0) -> Types.Inr __ +| Csyntax.Slabel (x, x0) -> Types.Inr __ +| Csyntax.Sgoto x -> Types.Inr __ +| Csyntax.Scost (x, x0) -> Types.Inr __ + +(** val store_value_of_type' : + Csyntax.type0 -> GenMem.mem -> (Pointers.block, Pointers.offset) + Types.prod -> Values.val0 -> GenMem.mem Types.option **) +let store_value_of_type' ty m l v = + let { Types.fst = loc; Types.snd = ofs } = l in + Csem.store_value_of_type ty m loc ofs v + +(** val exec_step : + Csem.genv -> Csem.state -> (IO.io_out, IO.io_in, (Events.trace, + Csem.state) Types.prod) IOMonad.iO **) +let rec exec_step ge = function +| Csem.State (f, s, k, e, m) -> + (match s with + | Csyntax.Sskip -> + (match k with + | Csem.Kstop -> + (match f.Csyntax.fn_return with + | Csyntax.Tvoid -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.Returnstate + (Values.Vundef, k, + (GenMem.free_list m (Csem.blocks_of_env e)))) } + | Csyntax.Tint (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tpointer x -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tarray (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tfunction (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tstruct (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tunion (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tcomp_ptr x -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState)) + | Csem.Kseq (s0, k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, s0, k', + e, m)) } + | Csem.Kwhile (a, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + (Csyntax.Swhile (a, s')), k', e, m)) } + | Csem.Kdowhile (a, s', k') -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a) in Obj.magic x) + (fun v tr -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io (exec_bool_of_val v (Csyntax.typeof a)))) + (fun b -> + match b with + | Bool.True -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.State (f, + (Csyntax.Sdowhile (a, s')), k', e, m)) }) + | Bool.False -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) })))) + | Csem.Kfor2 (a2, a3, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, a3, + (Csem.Kfor3 (a2, a3, s', k')), e, m)) } + | Csem.Kfor3 (a2, a3, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + (Csyntax.Sfor (Csyntax.Sskip, a2, a3, s')), k', e, m)) } + | Csem.Kswitch k' -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) } + | Csem.Kcall (x, x0, x1, x2) -> + (match f.Csyntax.fn_return with + | Csyntax.Tvoid -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.Returnstate + (Values.Vundef, k, + (GenMem.free_list m (Csem.blocks_of_env e)))) } + | Csyntax.Tint (x3, x4) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tpointer x3 -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tarray (x3, x4) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tfunction (x3, x4) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tstruct (x3, x4) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tunion (x3, x4) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csyntax.Tcomp_ptr x3 -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState))) + | Csyntax.Sassign (a1, a2) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_lvalue ge e m a1) in Obj.magic x) + (fun l tr1 -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a2) in Obj.magic x) + (fun v2 tr2 -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.opt_to_io (Errors.msg ErrorMessages.FailedStore) + (store_value_of_type' (Csyntax.typeof a1) m l v2))) + (fun m' -> + Obj.magic + (IO.ret { Types.fst = (Events.eapp tr1 tr2); Types.snd = + (Csem.State (f, Csyntax.Sskip, k, e, m')) }))))) + | Csyntax.Scall (lhs, a, al) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a) in Obj.magic x) + (fun vf tr2 -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_exprlist ge e m al) in + Obj.magic x) (fun vargs tr3 -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.opt_to_io (Errors.msg ErrorMessages.BadFunctionValue) + (Globalenvs.find_funct_id ge vf))) (fun fd id -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io + (TypeComparison.assert_type_eq (Csyntax.type_of_fundef fd) + (Csem.fun_typeof a)))) (fun _ -> + match lhs with + | Types.None -> + Obj.magic + (IO.ret { Types.fst = (Events.eapp tr2 tr3); Types.snd = + (Csem.Callstate (id, fd, vargs, (Csem.Kcall (Types.None, + f, e, k)), m)) }) + | Types.Some lhs' -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_lvalue ge e m lhs') in + Obj.magic x) (fun locofs tr1 -> + Obj.magic + (IO.ret { Types.fst = + (Events.eapp tr1 (Events.eapp tr2 tr3)); Types.snd = + (Csem.Callstate (id, fd, vargs, (Csem.Kcall + ((Types.Some { Types.fst = locofs; Types.snd = + (Csyntax.typeof lhs') }), f, e, k)), m)) }))))))) + | Csyntax.Ssequence (s1, s2) -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, s1, + (Csem.Kseq (s2, k)), e, m)) } + | Csyntax.Sifthenelse (a, s1, s2) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a) in Obj.magic x) + (fun v tr -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io (exec_bool_of_val v (Csyntax.typeof a)))) + (fun b -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.State (f, + (match b with + | Bool.True -> s1 + | Bool.False -> s2), k, e, m)) })))) + | Csyntax.Swhile (a, s') -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a) in Obj.magic x) + (fun v tr -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io (exec_bool_of_val v (Csyntax.typeof a)))) + (fun b -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = + (match b with + | Bool.True -> + Csem.State (f, s', (Csem.Kwhile (a, s', k)), e, m) + | Bool.False -> Csem.State (f, Csyntax.Sskip, k, e, m)) })))) + | Csyntax.Sdowhile (a, s') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, s', + (Csem.Kdowhile (a, s', k)), e, m)) } + | Csyntax.Sfor (a1, a2, a3, s') -> + (match is_Sskip a1 with + | Types.Inl _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a2) in Obj.magic x) + (fun v tr -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io (exec_bool_of_val v (Csyntax.typeof a2)))) + (fun b -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.State (f, + (match b with + | Bool.True -> s' + | Bool.False -> Csyntax.Sskip), + (match b with + | Bool.True -> Csem.Kfor2 (a2, a3, s', k) + | Bool.False -> k), e, m)) })))) + | Types.Inr _ -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, a1, + (Csem.Kseq ((Csyntax.Sfor (Csyntax.Sskip, a2, a3, s')), k)), e, + m)) }) + | Csyntax.Sbreak -> + (match k with + | Csem.Kstop -> IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kseq (s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sbreak, k', e, m)) } + | Csem.Kwhile (a, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) } + | Csem.Kdowhile (a, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) } + | Csem.Kfor2 (a2, a3, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) } + | Csem.Kfor3 (x, x0, x1, x2) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kswitch k' -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) } + | Csem.Kcall (x, x0, x1, x2) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState)) + | Csyntax.Scontinue -> + (match k with + | Csem.Kstop -> IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kseq (s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Scontinue, k', e, m)) } + | Csem.Kwhile (a, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + (Csyntax.Swhile (a, s')), k', e, m)) } + | Csem.Kdowhile (a, s', k') -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a) in Obj.magic x) + (fun v tr -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io (exec_bool_of_val v (Csyntax.typeof a)))) + (fun b -> + match b with + | Bool.True -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.State (f, + (Csyntax.Sdowhile (a, s')), k', e, m)) }) + | Bool.False -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) })))) + | Csem.Kfor2 (a2, a3, s', k') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, a3, + (Csem.Kfor3 (a2, a3, s', k')), e, m)) } + | Csem.Kfor3 (x, x0, x1, x2) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kswitch k' -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Scontinue, k', e, m)) } + | Csem.Kcall (x, x0, x1, x2) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState)) + | Csyntax.Sreturn a_opt -> + (match a_opt with + | Types.None -> + (match f.Csyntax.fn_return with + | Csyntax.Tvoid -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.Returnstate + (Values.Vundef, (Csem.call_cont k), + (GenMem.free_list m (Csem.blocks_of_env e)))) } + | Csyntax.Tint (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Csyntax.Tpointer x -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Csyntax.Tarray (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Csyntax.Tfunction (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Csyntax.Tstruct (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Csyntax.Tunion (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Csyntax.Tcomp_ptr x -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch)) + | Types.Some a -> + (match TypeComparison.type_eq_dec f.Csyntax.fn_return Csyntax.Tvoid with + | Types.Inl _ -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Types.Inr _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a) in + Obj.magic x) (fun v tr -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.Returnstate (v, + (Csem.call_cont k), + (GenMem.free_list m (Csem.blocks_of_env e)))) }))))) + | Csyntax.Sswitch (a, sl) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (exec_expr ge e m a) in Obj.magic x) + (fun v tr -> + match v with + | Values.Vundef -> + Obj.magic (IOMonad.Wrong (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vint (sz, n) -> + (match Csyntax.typeof a with + | Csyntax.Tvoid -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tint (sz', x) -> + (match TypeComparison.sz_eq_dec sz sz' with + | Types.Inl _ -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.opt_to_io + (Errors.msg ErrorMessages.TypeMismatch) + (Csem.select_switch sz n sl))) (fun sl' -> + Obj.magic + (IO.ret { Types.fst = tr; Types.snd = (Csem.State (f, + (Csem.seq_of_labeled_statement sl'), (Csem.Kswitch k), + e, m)) })) + | Types.Inr _ -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch))) + | Csyntax.Tpointer x -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tarray (x, x0) -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tfunction (x, x0) -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tstruct (x, x0) -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tunion (x, x0) -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tcomp_ptr x -> + Obj.magic (IOMonad.Wrong + (Errors.msg ErrorMessages.TypeMismatch))) + | Values.Vnull -> + Obj.magic (IOMonad.Wrong (Errors.msg ErrorMessages.TypeMismatch)) + | Values.Vptr x -> + Obj.magic (IOMonad.Wrong (Errors.msg ErrorMessages.TypeMismatch)))) + | Csyntax.Slabel (lbl, s') -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, s', k, e, + m)) } + | Csyntax.Sgoto lbl -> + (match Csem.find_label lbl f.Csyntax.fn_body (Csem.call_cont k) with + | Types.None -> + IOMonad.Wrong (List.Cons ((Errors.MSG ErrorMessages.UnknownLabel), + (List.Cons ((Errors.CTX (PreIdentifiers.SymbolTag, lbl)), + List.Nil)))) + | Types.Some sk' -> + let { Types.fst = s'; Types.snd = k' } = sk' in + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, s', k', + e, m)) }) + | Csyntax.Scost (lbl, s') -> + IO.ret { Types.fst = (Events.echarge lbl); Types.snd = (Csem.State (f, + s', k, e, m)) }) +| Csem.Callstate (x, f0, vargs, k, m) -> + (match f0 with + | Csyntax.CL_Internal f -> + let { Types.fst = e; Types.snd = m1 } = + exec_alloc_variables Csem.empty_env m + (List.append f.Csyntax.fn_params f.Csyntax.fn_vars) + in + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (let x0 = + IOMonad.err_to_io + (exec_bind_parameters e m1 f.Csyntax.fn_params vargs) + in + Obj.magic x0) (fun m2 -> + Obj.magic + (IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + f.Csyntax.fn_body, k, e, m2)) }))) + | Csyntax.CL_External (f, argtys, retty) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (let x0 = + IOMonad.err_to_io + (IO.check_eventval_list vargs + (Csyntax.typlist_of_typelist argtys)) + in + Obj.magic x0) (fun evargs -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IO.do_io f evargs + (AST.proj_sig_res (Csyntax.signature_of_type argtys retty)))) + (fun evres -> + Obj.magic + (IO.ret { Types.fst = + (Events.eextcall f evargs + (IO.mk_eventval + (AST.proj_sig_res + (Csyntax.signature_of_type argtys retty)) evres)); + Types.snd = (Csem.Returnstate + ((IO.mk_val + (AST.proj_sig_res (Csyntax.signature_of_type argtys retty)) + evres), k, m)) }))))) +| Csem.Returnstate (res, k, m) -> + (match k with + | Csem.Kstop -> + (match res with + | Values.Vundef -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Values.Vint (sz, r) -> + (match sz with + | AST.I8 -> + (fun x -> IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch)) + | AST.I16 -> + (fun x -> IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch)) + | AST.I32 -> + (fun r0 -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.Finalstate + r0) })) r + | Values.Vnull -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch) + | Values.Vptr x -> + IOMonad.Wrong (Errors.msg ErrorMessages.ReturnMismatch)) + | Csem.Kseq (x, x0) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kwhile (x, x0, x1) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kdowhile (x, x0, x1) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kfor2 (x, x0, x1, x2) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kfor3 (x, x0, x1, x2) -> + IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kswitch x -> IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + | Csem.Kcall (r, f, e, k') -> + (match r with + | Types.None -> + IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m)) } + | Types.Some r' -> + let { Types.fst = l; Types.snd = ty } = r' in + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.opt_to_io (Errors.msg ErrorMessages.FailedStore) + (store_value_of_type' ty m l res))) (fun m' -> + Obj.magic + (IO.ret { Types.fst = Events.e0; Types.snd = (Csem.State (f, + Csyntax.Sskip, k', e, m')) }))))) +| Csem.Finalstate r -> IOMonad.Wrong (Errors.msg ErrorMessages.NonsenseState) + +(** val make_global : Csyntax.clight_program -> Csem.genv **) +let make_global p = + Globalenvs.globalenv Types.fst p + +(** val make_initial_state : + Csyntax.clight_program -> Csem.state Errors.res **) +let rec make_initial_state p = + let ge = make_global p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Globalenvs.init_mem Types.fst p)) (fun m0 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.MainMissing) + (Globalenvs.find_symbol ge p.AST.prog_main))) (fun b -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.MainMissing) + (Globalenvs.find_funct_ptr ge b))) (fun f -> + Obj.magic (Errors.OK (Csem.Callstate (p.AST.prog_main, f, List.Nil, + Csem.Kstop, m0))))))) + +(** val is_final : Csem.state -> Integers.int Types.option **) +let rec is_final = function +| Csem.State (x, x0, x1, x2, x3) -> Types.None +| Csem.Callstate (x, x0, x1, x2, x3) -> Types.None +| Csem.Returnstate (x, x0, x1) -> Types.None +| Csem.Finalstate r -> Types.Some r + +(** val is_final_state : + Csem.state -> (Integers.int Types.sig0, __) Types.sum **) +let is_final_state st = + Csem.state_rect_Type0 (fun f s k e m -> Types.Inr __) (fun vf f l k m -> + Types.Inr __) (fun v k m -> Types.Inr __) (fun r -> Types.Inl r) st + +(** val exec_steps : + Nat.nat -> Csem.genv -> Csem.state -> (IO.io_out, IO.io_in, + (Events.trace, Csem.state) Types.prod) IOMonad.iO **) +let rec exec_steps n ge s = + match is_final_state s with + | Types.Inl x -> IO.ret { Types.fst = Events.e0; Types.snd = s } + | Types.Inr _ -> + (match n with + | Nat.O -> IO.ret { Types.fst = Events.e0; Types.snd = s } + | Nat.S n' -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (Obj.magic (exec_step ge s)) (fun t s' -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (Obj.magic (exec_steps n' ge s')) (fun t' s'' -> + Obj.magic + (IO.ret { Types.fst = (Events.eapp t t'); Types.snd = s'' }))))) + +(** val clight_exec : (IO.io_out, IO.io_in) SmallstepExec.trans_system **) +let clight_exec = + { SmallstepExec.is_final = (fun x -> Obj.magic is_final); + SmallstepExec.step = (Obj.magic exec_step) } + +(** val clight_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let clight_fullexec = + { SmallstepExec.es1 = clight_exec; SmallstepExec.make_global = + (Obj.magic make_global); SmallstepExec.make_initial_state = + (Obj.magic make_initial_state) } + diff --git a/extracted/cexec.mli b/extracted/cexec.mli new file mode 100644 index 0000000..0e4151d --- /dev/null +++ b/extracted/cexec.mli @@ -0,0 +1,185 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open IO + +open SmallstepExec + +open TypeComparison + +open ClassifyOp + +open Smallstep + +open Csyntax + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +val exec_bool_of_val : Values.val0 -> Csyntax.type0 -> Bool.bool Errors.res + +val try_cast_null : + GenMem.mem -> AST.intsize -> BitVector.bitVector -> Csyntax.type0 -> + Csyntax.type0 -> Values.val0 Errors.res + +val ptr_like_type : Csyntax.type0 -> Bool.bool + +val exec_cast : + GenMem.mem -> Values.val0 -> Csyntax.type0 -> Csyntax.type0 -> Values.val0 + Errors.res + +val load_value_of_type' : + Csyntax.type0 -> GenMem.mem -> (Pointers.block, Pointers.offset) Types.prod + -> Values.val0 Types.option + +val exec_lvalue : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr -> ((Pointers.block, + Pointers.offset) Types.prod, Events.trace) Types.prod Errors.res + +val exec_lvalue' : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr_descr -> Csyntax.type0 + -> ((Pointers.block, Pointers.offset) Types.prod, Events.trace) Types.prod + Errors.res + +val exec_expr : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr -> (Values.val0, + Events.trace) Types.prod Errors.res + +val exec_exprlist : + Csem.genv -> Csem.env -> GenMem.mem -> Csyntax.expr List.list -> + (Values.val0 List.list, Events.trace) Types.prod Errors.res + +val exec_alloc_variables : + Csem.env -> GenMem.mem -> (AST.ident, Csyntax.type0) Types.prod List.list + -> (Csem.env, GenMem.mem) Types.prod + +val exec_bind_parameters : + Csem.env -> GenMem.mem -> (AST.ident, Csyntax.type0) Types.prod List.list + -> Values.val0 List.list -> GenMem.mem Errors.res + +val is_is_call_cont : Csem.cont -> (__, __) Types.sum + +val is_Sskip : Csyntax.statement -> (__, __) Types.sum + +val store_value_of_type' : + Csyntax.type0 -> GenMem.mem -> (Pointers.block, Pointers.offset) Types.prod + -> Values.val0 -> GenMem.mem Types.option + +val exec_step : + Csem.genv -> Csem.state -> (IO.io_out, IO.io_in, (Events.trace, Csem.state) + Types.prod) IOMonad.iO + +val make_global : Csyntax.clight_program -> Csem.genv + +val make_initial_state : Csyntax.clight_program -> Csem.state Errors.res + +val is_final : Csem.state -> Integers.int Types.option + +val is_final_state : Csem.state -> (Integers.int Types.sig0, __) Types.sum + +val exec_steps : + Nat.nat -> Csem.genv -> Csem.state -> (IO.io_out, IO.io_in, (Events.trace, + Csem.state) Types.prod) IOMonad.iO + +val clight_exec : (IO.io_out, IO.io_in) SmallstepExec.trans_system + +val clight_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec + diff --git a/extracted/cexecInd.ml b/extracted/cexecInd.ml new file mode 100644 index 0000000..36e2ed8 --- /dev/null +++ b/extracted/cexecInd.ml @@ -0,0 +1,76 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + diff --git a/extracted/cexecInd.mli b/extracted/cexecInd.mli new file mode 100644 index 0000000..36e2ed8 --- /dev/null +++ b/extracted/cexecInd.mli @@ -0,0 +1,76 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + diff --git a/extracted/cexecSound.ml b/extracted/cexecSound.ml new file mode 100644 index 0000000..61ca0bf --- /dev/null +++ b/extracted/cexecSound.ml @@ -0,0 +1,120 @@ +open Preamble + +open TypeComparison + +open ClassifyOp + +open Smallstep + +open Csyntax + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open IO + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open Cexec + +open CexecInd + diff --git a/extracted/cexecSound.mli b/extracted/cexecSound.mli new file mode 100644 index 0000000..61ca0bf --- /dev/null +++ b/extracted/cexecSound.mli @@ -0,0 +1,120 @@ +open Preamble + +open TypeComparison + +open ClassifyOp + +open Smallstep + +open Csyntax + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open IO + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open Cexec + +open CexecInd + diff --git a/extracted/classifyOp.ml b/extracted/classifyOp.ml new file mode 100644 index 0000000..663045d --- /dev/null +++ b/extracted/classifyOp.ml @@ -0,0 +1,885 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +(** val ptr_type : Csyntax.type0 -> Nat.nat Types.option -> Csyntax.type0 **) +let ptr_type ty = function +| Types.None -> Csyntax.Tpointer ty +| Types.Some n' -> Csyntax.Tarray (ty, n') + +type classify_add_cases = +| Add_case_ii of AST.intsize * AST.signedness +| Add_case_pi of Nat.nat Types.option * Csyntax.type0 * AST.intsize + * AST.signedness +| Add_case_ip of Nat.nat Types.option * AST.intsize * AST.signedness + * Csyntax.type0 +| Add_default of Csyntax.type0 * Csyntax.type0 + +(** val classify_add_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 **) +let rec classify_add_cases_rect_Type4 h_add_case_ii h_add_case_pi h_add_case_ip h_add_default x_7441 x_7440 = function +| Add_case_ii (sz, sg) -> h_add_case_ii sz sg +| Add_case_pi (n, ty, sz, sg) -> h_add_case_pi n ty sz sg +| Add_case_ip (n, sz, sg, ty) -> h_add_case_ip n sz sg ty +| Add_default (ty1, ty2) -> h_add_default ty1 ty2 + +(** val classify_add_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 **) +let rec classify_add_cases_rect_Type5 h_add_case_ii h_add_case_pi h_add_case_ip h_add_default x_7448 x_7447 = function +| Add_case_ii (sz, sg) -> h_add_case_ii sz sg +| Add_case_pi (n, ty, sz, sg) -> h_add_case_pi n ty sz sg +| Add_case_ip (n, sz, sg, ty) -> h_add_case_ip n sz sg ty +| Add_default (ty1, ty2) -> h_add_default ty1 ty2 + +(** val classify_add_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 **) +let rec classify_add_cases_rect_Type3 h_add_case_ii h_add_case_pi h_add_case_ip h_add_default x_7455 x_7454 = function +| Add_case_ii (sz, sg) -> h_add_case_ii sz sg +| Add_case_pi (n, ty, sz, sg) -> h_add_case_pi n ty sz sg +| Add_case_ip (n, sz, sg, ty) -> h_add_case_ip n sz sg ty +| Add_default (ty1, ty2) -> h_add_default ty1 ty2 + +(** val classify_add_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 **) +let rec classify_add_cases_rect_Type2 h_add_case_ii h_add_case_pi h_add_case_ip h_add_default x_7462 x_7461 = function +| Add_case_ii (sz, sg) -> h_add_case_ii sz sg +| Add_case_pi (n, ty, sz, sg) -> h_add_case_pi n ty sz sg +| Add_case_ip (n, sz, sg, ty) -> h_add_case_ip n sz sg ty +| Add_default (ty1, ty2) -> h_add_default ty1 ty2 + +(** val classify_add_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 **) +let rec classify_add_cases_rect_Type1 h_add_case_ii h_add_case_pi h_add_case_ip h_add_default x_7469 x_7468 = function +| Add_case_ii (sz, sg) -> h_add_case_ii sz sg +| Add_case_pi (n, ty, sz, sg) -> h_add_case_pi n ty sz sg +| Add_case_ip (n, sz, sg, ty) -> h_add_case_ip n sz sg ty +| Add_default (ty1, ty2) -> h_add_default ty1 ty2 + +(** val classify_add_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 **) +let rec classify_add_cases_rect_Type0 h_add_case_ii h_add_case_pi h_add_case_ip h_add_default x_7476 x_7475 = function +| Add_case_ii (sz, sg) -> h_add_case_ii sz sg +| Add_case_pi (n, ty, sz, sg) -> h_add_case_pi n ty sz sg +| Add_case_ip (n, sz, sg, ty) -> h_add_case_ip n sz sg ty +| Add_default (ty1, ty2) -> h_add_default ty1 ty2 + +(** val classify_add_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> AST.intsize -> AST.signedness -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_add_cases_inv_rect_Type4 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_add_cases_rect_Type4 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_add_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> AST.intsize -> AST.signedness -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_add_cases_inv_rect_Type3 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_add_cases_rect_Type3 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_add_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> AST.intsize -> AST.signedness -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_add_cases_inv_rect_Type2 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_add_cases_rect_Type2 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_add_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> AST.intsize -> AST.signedness -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_add_cases_inv_rect_Type1 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_add_cases_rect_Type1 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_add_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> AST.intsize -> AST.signedness -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_add_cases_inv_rect_Type0 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_add_cases_rect_Type0 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_add_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> + classify_add_cases -> __ **) +let classify_add_cases_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Add_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Add_case_pi (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Add_case_ip (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Add_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_add_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> + classify_add_cases -> __ **) +let classify_add_cases_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Add_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Add_case_pi (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Add_case_ip (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Add_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_add : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases **) +let classify_add ty1 ty2 = + match ty1 with + | Csyntax.Tvoid -> Add_default (Csyntax.Tvoid, ty2) + | Csyntax.Tint (sz1, sg1) -> + (match ty2 with + | Csyntax.Tvoid -> + Add_default ((Csyntax.Tint (sz1, sg1)), Csyntax.Tvoid) + | Csyntax.Tint (sz2, sg2) -> + AST.inttyp_eq_elim' sz1 sz2 sg1 sg2 (Add_case_ii (sz1, sg1)) + (Add_default ((Csyntax.Tint (sz1, sg1)), (Csyntax.Tint (sz2, sg2)))) + | Csyntax.Tpointer ty -> Add_case_ip (Types.None, sz1, sg1, ty) + | Csyntax.Tarray (ty, n) -> Add_case_ip ((Types.Some n), sz1, sg1, ty) + | Csyntax.Tfunction (x, x0) -> + Add_default ((Csyntax.Tint (sz1, sg1)), (Csyntax.Tfunction (x, x0))) + | Csyntax.Tstruct (x, x0) -> + Add_default ((Csyntax.Tint (sz1, sg1)), (Csyntax.Tstruct (x, x0))) + | Csyntax.Tunion (x, x0) -> + Add_default ((Csyntax.Tint (sz1, sg1)), (Csyntax.Tunion (x, x0))) + | Csyntax.Tcomp_ptr x -> + Add_default ((Csyntax.Tint (sz1, sg1)), (Csyntax.Tcomp_ptr x))) + | Csyntax.Tpointer ty -> + (match ty2 with + | Csyntax.Tvoid -> Add_default ((ptr_type ty Types.None), Csyntax.Tvoid) + | Csyntax.Tint (x, x0) -> Add_case_pi (Types.None, ty, x, x0) + | Csyntax.Tpointer x -> + Add_default ((ptr_type ty Types.None), (Csyntax.Tpointer x)) + | Csyntax.Tarray (x, x0) -> + Add_default ((ptr_type ty Types.None), (Csyntax.Tarray (x, x0))) + | Csyntax.Tfunction (x, x0) -> + Add_default ((ptr_type ty Types.None), (Csyntax.Tfunction (x, x0))) + | Csyntax.Tstruct (x, x0) -> + Add_default ((ptr_type ty Types.None), (Csyntax.Tstruct (x, x0))) + | Csyntax.Tunion (x, x0) -> + Add_default ((ptr_type ty Types.None), (Csyntax.Tunion (x, x0))) + | Csyntax.Tcomp_ptr x -> + Add_default ((ptr_type ty Types.None), (Csyntax.Tcomp_ptr x))) + | Csyntax.Tarray (ty, n) -> + (match ty2 with + | Csyntax.Tvoid -> + Add_default ((ptr_type ty (Types.Some n)), Csyntax.Tvoid) + | Csyntax.Tint (x, x0) -> Add_case_pi ((Types.Some n), ty, x, x0) + | Csyntax.Tpointer x -> + Add_default ((ptr_type ty (Types.Some n)), (Csyntax.Tpointer x)) + | Csyntax.Tarray (x, x0) -> + Add_default ((ptr_type ty (Types.Some n)), (Csyntax.Tarray (x, x0))) + | Csyntax.Tfunction (x, x0) -> + Add_default ((ptr_type ty (Types.Some n)), (Csyntax.Tfunction (x, + x0))) + | Csyntax.Tstruct (x, x0) -> + Add_default ((ptr_type ty (Types.Some n)), (Csyntax.Tstruct (x, x0))) + | Csyntax.Tunion (x, x0) -> + Add_default ((ptr_type ty (Types.Some n)), (Csyntax.Tunion (x, x0))) + | Csyntax.Tcomp_ptr x -> + Add_default ((ptr_type ty (Types.Some n)), (Csyntax.Tcomp_ptr x))) + | Csyntax.Tfunction (x, x0) -> + Add_default ((Csyntax.Tfunction (x, x0)), ty2) + | Csyntax.Tstruct (x, x0) -> Add_default ((Csyntax.Tstruct (x, x0)), ty2) + | Csyntax.Tunion (x, x0) -> Add_default ((Csyntax.Tunion (x, x0)), ty2) + | Csyntax.Tcomp_ptr x -> Add_default ((Csyntax.Tcomp_ptr x), ty2) + +type classify_sub_cases = +| Sub_case_ii of AST.intsize * AST.signedness +| Sub_case_pi of Nat.nat Types.option * Csyntax.type0 * AST.intsize + * AST.signedness +| Sub_case_pp of Nat.nat Types.option * Nat.nat Types.option * Csyntax.type0 + * Csyntax.type0 +| Sub_default of Csyntax.type0 * Csyntax.type0 + +(** val classify_sub_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 **) +let rec classify_sub_cases_rect_Type4 h_sub_case_ii h_sub_case_pi h_sub_case_pp h_sub_default x_7532 x_7531 = function +| Sub_case_ii (sz, sg) -> h_sub_case_ii sz sg +| Sub_case_pi (n, ty, sz, sg) -> h_sub_case_pi n ty sz sg +| Sub_case_pp (n1, n2, ty1, ty2) -> h_sub_case_pp n1 n2 ty1 ty2 +| Sub_default (ty1, ty2) -> h_sub_default ty1 ty2 + +(** val classify_sub_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 **) +let rec classify_sub_cases_rect_Type5 h_sub_case_ii h_sub_case_pi h_sub_case_pp h_sub_default x_7539 x_7538 = function +| Sub_case_ii (sz, sg) -> h_sub_case_ii sz sg +| Sub_case_pi (n, ty, sz, sg) -> h_sub_case_pi n ty sz sg +| Sub_case_pp (n1, n2, ty1, ty2) -> h_sub_case_pp n1 n2 ty1 ty2 +| Sub_default (ty1, ty2) -> h_sub_default ty1 ty2 + +(** val classify_sub_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 **) +let rec classify_sub_cases_rect_Type3 h_sub_case_ii h_sub_case_pi h_sub_case_pp h_sub_default x_7546 x_7545 = function +| Sub_case_ii (sz, sg) -> h_sub_case_ii sz sg +| Sub_case_pi (n, ty, sz, sg) -> h_sub_case_pi n ty sz sg +| Sub_case_pp (n1, n2, ty1, ty2) -> h_sub_case_pp n1 n2 ty1 ty2 +| Sub_default (ty1, ty2) -> h_sub_default ty1 ty2 + +(** val classify_sub_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 **) +let rec classify_sub_cases_rect_Type2 h_sub_case_ii h_sub_case_pi h_sub_case_pp h_sub_default x_7553 x_7552 = function +| Sub_case_ii (sz, sg) -> h_sub_case_ii sz sg +| Sub_case_pi (n, ty, sz, sg) -> h_sub_case_pi n ty sz sg +| Sub_case_pp (n1, n2, ty1, ty2) -> h_sub_case_pp n1 n2 ty1 ty2 +| Sub_default (ty1, ty2) -> h_sub_default ty1 ty2 + +(** val classify_sub_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 **) +let rec classify_sub_cases_rect_Type1 h_sub_case_ii h_sub_case_pi h_sub_case_pp h_sub_default x_7560 x_7559 = function +| Sub_case_ii (sz, sg) -> h_sub_case_ii sz sg +| Sub_case_pi (n, ty, sz, sg) -> h_sub_case_pi n ty sz sg +| Sub_case_pp (n1, n2, ty1, ty2) -> h_sub_case_pp n1 n2 ty1 ty2 +| Sub_default (ty1, ty2) -> h_sub_default ty1 ty2 + +(** val classify_sub_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 **) +let rec classify_sub_cases_rect_Type0 h_sub_case_ii h_sub_case_pi h_sub_case_pp h_sub_default x_7567 x_7566 = function +| Sub_case_ii (sz, sg) -> h_sub_case_ii sz sg +| Sub_case_pi (n, ty, sz, sg) -> h_sub_case_pi n ty sz sg +| Sub_case_pp (n1, n2, ty1, ty2) -> h_sub_case_pp n1 n2 ty1 ty2 +| Sub_default (ty1, ty2) -> h_sub_default ty1 ty2 + +(** val classify_sub_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_sub_cases_inv_rect_Type4 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_sub_cases_rect_Type4 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_sub_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_sub_cases_inv_rect_Type3 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_sub_cases_rect_Type3 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_sub_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_sub_cases_inv_rect_Type2 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_sub_cases_rect_Type2 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_sub_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_sub_cases_inv_rect_Type1 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_sub_cases_rect_Type1 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_sub_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) + -> (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_sub_cases_inv_rect_Type0 x1 x2 hterm h1 h2 h3 h4 = + let hcut = classify_sub_cases_rect_Type0 h1 h2 h3 h4 x1 x2 hterm in + hcut __ __ __ + +(** val classify_sub_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> + classify_sub_cases -> __ **) +let classify_sub_cases_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Sub_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Sub_case_pi (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Sub_case_pp (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Sub_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_sub_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> + classify_sub_cases -> __ **) +let classify_sub_cases_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Sub_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Sub_case_pi (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Sub_case_pp (a0, a10, a20, a3) -> + Obj.magic (fun _ dH -> dH __ __ __ __) + | Sub_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_sub : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases **) +let classify_sub ty1 ty2 = + match ty1 with + | Csyntax.Tvoid -> Sub_default (Csyntax.Tvoid, ty2) + | Csyntax.Tint (sz1, sg1) -> + TypeComparison.if_type_eq (Csyntax.Tint (sz1, sg1)) ty2 (Sub_case_ii + (sz1, sg1)) (Sub_default ((Csyntax.Tint (sz1, sg1)), ty2)) + | Csyntax.Tpointer ty -> + (match ty2 with + | Csyntax.Tvoid -> Sub_default ((ptr_type ty Types.None), Csyntax.Tvoid) + | Csyntax.Tint (sz, sg) -> Sub_case_pi (Types.None, ty, sz, sg) + | Csyntax.Tpointer x -> Sub_case_pp (Types.None, Types.None, ty, x) + | Csyntax.Tarray (x, n2) -> + Sub_case_pp (Types.None, (Types.Some n2), ty, x) + | Csyntax.Tfunction (x, x0) -> + Sub_default ((ptr_type ty Types.None), (Csyntax.Tfunction (x, x0))) + | Csyntax.Tstruct (x, x0) -> + Sub_default ((ptr_type ty Types.None), (Csyntax.Tstruct (x, x0))) + | Csyntax.Tunion (x, x0) -> + Sub_default ((ptr_type ty Types.None), (Csyntax.Tunion (x, x0))) + | Csyntax.Tcomp_ptr x -> + Sub_default ((ptr_type ty Types.None), (Csyntax.Tcomp_ptr x))) + | Csyntax.Tarray (ty, n1) -> + (match ty2 with + | Csyntax.Tvoid -> + Sub_default ((ptr_type ty (Types.Some n1)), Csyntax.Tvoid) + | Csyntax.Tint (x, x0) -> Sub_case_pi ((Types.Some n1), ty, x, x0) + | Csyntax.Tpointer x -> Sub_case_pp ((Types.Some n1), Types.None, ty, x) + | Csyntax.Tarray (x, n2) -> + Sub_case_pp ((Types.Some n1), (Types.Some n2), ty, x) + | Csyntax.Tfunction (x, x0) -> + Sub_default ((ptr_type ty (Types.Some n1)), (Csyntax.Tfunction (x, + x0))) + | Csyntax.Tstruct (x, x0) -> + Sub_default ((ptr_type ty (Types.Some n1)), (Csyntax.Tstruct (x, x0))) + | Csyntax.Tunion (x, x0) -> + Sub_default ((ptr_type ty (Types.Some n1)), (Csyntax.Tunion (x, x0))) + | Csyntax.Tcomp_ptr x -> + Sub_default ((ptr_type ty (Types.Some n1)), (Csyntax.Tcomp_ptr x))) + | Csyntax.Tfunction (x, x0) -> + Sub_default ((Csyntax.Tfunction (x, x0)), ty2) + | Csyntax.Tstruct (x, x0) -> Sub_default ((Csyntax.Tstruct (x, x0)), ty2) + | Csyntax.Tunion (x, x0) -> Sub_default ((Csyntax.Tunion (x, x0)), ty2) + | Csyntax.Tcomp_ptr x -> Sub_default ((Csyntax.Tcomp_ptr x), ty2) + +type classify_aop_cases = +| Aop_case_ii of AST.intsize * AST.signedness +| Aop_default of Csyntax.type0 * Csyntax.type0 + +(** val classify_aop_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 **) +let rec classify_aop_cases_rect_Type4 h_aop_case_ii h_aop_default x_7621 x_7620 = function +| Aop_case_ii (sz, sg) -> h_aop_case_ii sz sg +| Aop_default (ty, ty') -> h_aop_default ty ty' + +(** val classify_aop_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 **) +let rec classify_aop_cases_rect_Type5 h_aop_case_ii h_aop_default x_7626 x_7625 = function +| Aop_case_ii (sz, sg) -> h_aop_case_ii sz sg +| Aop_default (ty, ty') -> h_aop_default ty ty' + +(** val classify_aop_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 **) +let rec classify_aop_cases_rect_Type3 h_aop_case_ii h_aop_default x_7631 x_7630 = function +| Aop_case_ii (sz, sg) -> h_aop_case_ii sz sg +| Aop_default (ty, ty') -> h_aop_default ty ty' + +(** val classify_aop_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 **) +let rec classify_aop_cases_rect_Type2 h_aop_case_ii h_aop_default x_7636 x_7635 = function +| Aop_case_ii (sz, sg) -> h_aop_case_ii sz sg +| Aop_default (ty, ty') -> h_aop_default ty ty' + +(** val classify_aop_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 **) +let rec classify_aop_cases_rect_Type1 h_aop_case_ii h_aop_default x_7641 x_7640 = function +| Aop_case_ii (sz, sg) -> h_aop_case_ii sz sg +| Aop_default (ty, ty') -> h_aop_default ty ty' + +(** val classify_aop_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 **) +let rec classify_aop_cases_rect_Type0 h_aop_case_ii h_aop_default x_7646 x_7645 = function +| Aop_case_ii (sz, sg) -> h_aop_case_ii sz sg +| Aop_default (ty, ty') -> h_aop_default ty ty' + +(** val classify_aop_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_aop_cases_inv_rect_Type4 x1 x2 hterm h1 h2 = + let hcut = classify_aop_cases_rect_Type4 h1 h2 x1 x2 hterm in hcut __ __ __ + +(** val classify_aop_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_aop_cases_inv_rect_Type3 x1 x2 hterm h1 h2 = + let hcut = classify_aop_cases_rect_Type3 h1 h2 x1 x2 hterm in hcut __ __ __ + +(** val classify_aop_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_aop_cases_inv_rect_Type2 x1 x2 hterm h1 h2 = + let hcut = classify_aop_cases_rect_Type2 h1 h2 x1 x2 hterm in hcut __ __ __ + +(** val classify_aop_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_aop_cases_inv_rect_Type1 x1 x2 hterm h1 h2 = + let hcut = classify_aop_cases_rect_Type1 h1 h2 x1 x2 hterm in hcut __ __ __ + +(** val classify_aop_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_aop_cases_inv_rect_Type0 x1 x2 hterm h1 h2 = + let hcut = classify_aop_cases_rect_Type0 h1 h2 x1 x2 hterm in hcut __ __ __ + +(** val classify_aop_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> + classify_aop_cases -> __ **) +let classify_aop_cases_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Aop_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Aop_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_aop_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> + classify_aop_cases -> __ **) +let classify_aop_cases_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Aop_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Aop_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_aop : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases **) +let classify_aop ty1 ty2 = + match ty1 with + | Csyntax.Tvoid -> Aop_default (Csyntax.Tvoid, ty2) + | Csyntax.Tint (sz1, sg1) -> + TypeComparison.if_type_eq (Csyntax.Tint (sz1, sg1)) ty2 (Aop_case_ii + (sz1, sg1)) (Aop_default ((Csyntax.Tint (sz1, sg1)), ty2)) + | Csyntax.Tpointer x -> Aop_default ((Csyntax.Tpointer x), ty2) + | Csyntax.Tarray (x, x0) -> Aop_default ((Csyntax.Tarray (x, x0)), ty2) + | Csyntax.Tfunction (x, x0) -> + Aop_default ((Csyntax.Tfunction (x, x0)), ty2) + | Csyntax.Tstruct (x, x0) -> Aop_default ((Csyntax.Tstruct (x, x0)), ty2) + | Csyntax.Tunion (x, x0) -> Aop_default ((Csyntax.Tunion (x, x0)), ty2) + | Csyntax.Tcomp_ptr x -> Aop_default ((Csyntax.Tcomp_ptr x), ty2) + +type classify_cmp_cases = +| Cmp_case_ii of AST.intsize * AST.signedness +| Cmp_case_pp of Nat.nat Types.option * Csyntax.type0 +| Cmp_default of Csyntax.type0 * Csyntax.type0 + +(** val classify_cmp_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 **) +let rec classify_cmp_cases_rect_Type4 h_cmp_case_ii h_cmp_case_pp h_cmp_default x_7687 x_7686 = function +| Cmp_case_ii (sz, sg) -> h_cmp_case_ii sz sg +| Cmp_case_pp (n, ty) -> h_cmp_case_pp n ty +| Cmp_default (ty, ty') -> h_cmp_default ty ty' + +(** val classify_cmp_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 **) +let rec classify_cmp_cases_rect_Type5 h_cmp_case_ii h_cmp_case_pp h_cmp_default x_7693 x_7692 = function +| Cmp_case_ii (sz, sg) -> h_cmp_case_ii sz sg +| Cmp_case_pp (n, ty) -> h_cmp_case_pp n ty +| Cmp_default (ty, ty') -> h_cmp_default ty ty' + +(** val classify_cmp_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 **) +let rec classify_cmp_cases_rect_Type3 h_cmp_case_ii h_cmp_case_pp h_cmp_default x_7699 x_7698 = function +| Cmp_case_ii (sz, sg) -> h_cmp_case_ii sz sg +| Cmp_case_pp (n, ty) -> h_cmp_case_pp n ty +| Cmp_default (ty, ty') -> h_cmp_default ty ty' + +(** val classify_cmp_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 **) +let rec classify_cmp_cases_rect_Type2 h_cmp_case_ii h_cmp_case_pp h_cmp_default x_7705 x_7704 = function +| Cmp_case_ii (sz, sg) -> h_cmp_case_ii sz sg +| Cmp_case_pp (n, ty) -> h_cmp_case_pp n ty +| Cmp_default (ty, ty') -> h_cmp_default ty ty' + +(** val classify_cmp_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 **) +let rec classify_cmp_cases_rect_Type1 h_cmp_case_ii h_cmp_case_pp h_cmp_default x_7711 x_7710 = function +| Cmp_case_ii (sz, sg) -> h_cmp_case_ii sz sg +| Cmp_case_pp (n, ty) -> h_cmp_case_pp n ty +| Cmp_default (ty, ty') -> h_cmp_default ty ty' + +(** val classify_cmp_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 **) +let rec classify_cmp_cases_rect_Type0 h_cmp_case_ii h_cmp_case_pp h_cmp_default x_7717 x_7716 = function +| Cmp_case_ii (sz, sg) -> h_cmp_case_ii sz sg +| Cmp_case_pp (n, ty) -> h_cmp_case_pp n ty +| Cmp_default (ty, ty') -> h_cmp_default ty ty' + +(** val classify_cmp_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_cmp_cases_inv_rect_Type4 x1 x2 hterm h1 h2 h3 = + let hcut = classify_cmp_cases_rect_Type4 h1 h2 h3 x1 x2 hterm in + hcut __ __ __ + +(** val classify_cmp_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_cmp_cases_inv_rect_Type3 x1 x2 hterm h1 h2 h3 = + let hcut = classify_cmp_cases_rect_Type3 h1 h2 h3 x1 x2 hterm in + hcut __ __ __ + +(** val classify_cmp_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_cmp_cases_inv_rect_Type2 x1 x2 hterm h1 h2 h3 = + let hcut = classify_cmp_cases_rect_Type2 h1 h2 h3 x1 x2 hterm in + hcut __ __ __ + +(** val classify_cmp_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_cmp_cases_inv_rect_Type1 x1 x2 hterm h1 h2 h3 = + let hcut = classify_cmp_cases_rect_Type1 h1 h2 h3 x1 x2 hterm in + hcut __ __ __ + +(** val classify_cmp_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let classify_cmp_cases_inv_rect_Type0 x1 x2 hterm h1 h2 h3 = + let hcut = classify_cmp_cases_rect_Type0 h1 h2 h3 x1 x2 hterm in + hcut __ __ __ + +(** val classify_cmp_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> + classify_cmp_cases -> __ **) +let classify_cmp_cases_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Cmp_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Cmp_case_pp (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Cmp_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_cmp_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> + classify_cmp_cases -> __ **) +let classify_cmp_cases_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Cmp_case_ii (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Cmp_case_pp (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Cmp_default (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val classify_cmp : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases **) +let classify_cmp ty1 ty2 = + match ty1 with + | Csyntax.Tvoid -> Cmp_default (Csyntax.Tvoid, ty2) + | Csyntax.Tint (sz1, sg1) -> + TypeComparison.if_type_eq (Csyntax.Tint (sz1, sg1)) ty2 (Cmp_case_ii + (sz1, sg1)) (Cmp_default ((Csyntax.Tint (sz1, sg1)), ty2)) + | Csyntax.Tpointer ty1' -> + TypeComparison.if_type_eq (Csyntax.Tpointer ty1') ty2 (Cmp_case_pp + (Types.None, ty1')) (Cmp_default ((Csyntax.Tpointer ty1'), ty2)) + | Csyntax.Tarray (ty1', n1) -> + TypeComparison.if_type_eq (Csyntax.Tarray (ty1', n1)) ty2 (Cmp_case_pp + ((Types.Some n1), ty1')) (Cmp_default ((Csyntax.Tarray (ty1', n1)), + ty2)) + | Csyntax.Tfunction (x, x0) -> + Cmp_default ((Csyntax.Tfunction (x, x0)), ty2) + | Csyntax.Tstruct (x, x0) -> Cmp_default ((Csyntax.Tstruct (x, x0)), ty2) + | Csyntax.Tunion (x, x0) -> Cmp_default ((Csyntax.Tunion (x, x0)), ty2) + | Csyntax.Tcomp_ptr x -> Cmp_default ((Csyntax.Tcomp_ptr x), ty2) + +type classify_fun_cases = +| Fun_case_f of Csyntax.typelist * Csyntax.type0 +| Fun_default + +(** val classify_fun_cases_rect_Type4 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases + -> 'a1 **) +let rec classify_fun_cases_rect_Type4 h_fun_case_f h_fun_default = function +| Fun_case_f (x_7765, x_7764) -> h_fun_case_f x_7765 x_7764 +| Fun_default -> h_fun_default + +(** val classify_fun_cases_rect_Type5 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases + -> 'a1 **) +let rec classify_fun_cases_rect_Type5 h_fun_case_f h_fun_default = function +| Fun_case_f (x_7770, x_7769) -> h_fun_case_f x_7770 x_7769 +| Fun_default -> h_fun_default + +(** val classify_fun_cases_rect_Type3 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases + -> 'a1 **) +let rec classify_fun_cases_rect_Type3 h_fun_case_f h_fun_default = function +| Fun_case_f (x_7775, x_7774) -> h_fun_case_f x_7775 x_7774 +| Fun_default -> h_fun_default + +(** val classify_fun_cases_rect_Type2 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases + -> 'a1 **) +let rec classify_fun_cases_rect_Type2 h_fun_case_f h_fun_default = function +| Fun_case_f (x_7780, x_7779) -> h_fun_case_f x_7780 x_7779 +| Fun_default -> h_fun_default + +(** val classify_fun_cases_rect_Type1 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases + -> 'a1 **) +let rec classify_fun_cases_rect_Type1 h_fun_case_f h_fun_default = function +| Fun_case_f (x_7785, x_7784) -> h_fun_case_f x_7785 x_7784 +| Fun_default -> h_fun_default + +(** val classify_fun_cases_rect_Type0 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases + -> 'a1 **) +let rec classify_fun_cases_rect_Type0 h_fun_case_f h_fun_default = function +| Fun_case_f (x_7790, x_7789) -> h_fun_case_f x_7790 x_7789 +| Fun_default -> h_fun_default + +(** val classify_fun_cases_inv_rect_Type4 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let classify_fun_cases_inv_rect_Type4 hterm h1 h2 = + let hcut = classify_fun_cases_rect_Type4 h1 h2 hterm in hcut __ + +(** val classify_fun_cases_inv_rect_Type3 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let classify_fun_cases_inv_rect_Type3 hterm h1 h2 = + let hcut = classify_fun_cases_rect_Type3 h1 h2 hterm in hcut __ + +(** val classify_fun_cases_inv_rect_Type2 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let classify_fun_cases_inv_rect_Type2 hterm h1 h2 = + let hcut = classify_fun_cases_rect_Type2 h1 h2 hterm in hcut __ + +(** val classify_fun_cases_inv_rect_Type1 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let classify_fun_cases_inv_rect_Type1 hterm h1 h2 = + let hcut = classify_fun_cases_rect_Type1 h1 h2 hterm in hcut __ + +(** val classify_fun_cases_inv_rect_Type0 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let classify_fun_cases_inv_rect_Type0 hterm h1 h2 = + let hcut = classify_fun_cases_rect_Type0 h1 h2 hterm in hcut __ + +(** val classify_fun_cases_discr : + classify_fun_cases -> classify_fun_cases -> __ **) +let classify_fun_cases_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Fun_case_f (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Fun_default -> Obj.magic (fun _ dH -> dH)) y + +(** val classify_fun_cases_jmdiscr : + classify_fun_cases -> classify_fun_cases -> __ **) +let classify_fun_cases_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Fun_case_f (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Fun_default -> Obj.magic (fun _ dH -> dH)) y + +(** val classify_fun : Csyntax.type0 -> classify_fun_cases **) +let classify_fun = function +| Csyntax.Tvoid -> Fun_default +| Csyntax.Tint (x, x0) -> Fun_default +| Csyntax.Tpointer ty' -> + (match ty' with + | Csyntax.Tvoid -> Fun_default + | Csyntax.Tint (x, x0) -> Fun_default + | Csyntax.Tpointer x -> Fun_default + | Csyntax.Tarray (x, x0) -> Fun_default + | Csyntax.Tfunction (args, res) -> Fun_case_f (args, res) + | Csyntax.Tstruct (x, x0) -> Fun_default + | Csyntax.Tunion (x, x0) -> Fun_default + | Csyntax.Tcomp_ptr x -> Fun_default) +| Csyntax.Tarray (x, x0) -> Fun_default +| Csyntax.Tfunction (args, res) -> Fun_case_f (args, res) +| Csyntax.Tstruct (x, x0) -> Fun_default +| Csyntax.Tunion (x, x0) -> Fun_default +| Csyntax.Tcomp_ptr x -> Fun_default + diff --git a/extracted/classifyOp.mli b/extracted/classifyOp.mli new file mode 100644 index 0000000..66c1691 --- /dev/null +++ b/extracted/classifyOp.mli @@ -0,0 +1,473 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +val ptr_type : Csyntax.type0 -> Nat.nat Types.option -> Csyntax.type0 + +type classify_add_cases = +| Add_case_ii of AST.intsize * AST.signedness +| Add_case_pi of Nat.nat Types.option * Csyntax.type0 * AST.intsize + * AST.signedness +| Add_case_ip of Nat.nat Types.option * AST.intsize * AST.signedness + * Csyntax.type0 +| Add_default of Csyntax.type0 * Csyntax.type0 + +val classify_add_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 + +val classify_add_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 + +val classify_add_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 + +val classify_add_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 + +val classify_add_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 + +val classify_add_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> 'a1) -> + (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> Csyntax.type0 + -> classify_add_cases -> 'a1 + +val classify_add_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> + __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val classify_add_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> + __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val classify_add_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> + __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val classify_add_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> + __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val classify_add_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> AST.intsize -> AST.signedness -> Csyntax.type0 -> + __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val classify_add_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> classify_add_cases + -> __ + +val classify_add_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_add_cases -> classify_add_cases + -> __ + +val classify_add : Csyntax.type0 -> Csyntax.type0 -> classify_add_cases + +type classify_sub_cases = +| Sub_case_ii of AST.intsize * AST.signedness +| Sub_case_pi of Nat.nat Types.option * Csyntax.type0 * AST.intsize + * AST.signedness +| Sub_case_pp of Nat.nat Types.option * Nat.nat Types.option * Csyntax.type0 + * Csyntax.type0 +| Sub_default of Csyntax.type0 * Csyntax.type0 + +val classify_sub_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 + +val classify_sub_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 + +val classify_sub_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 + +val classify_sub_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 + +val classify_sub_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 + +val classify_sub_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat + Types.option -> Nat.nat Types.option -> Csyntax.type0 -> Csyntax.type0 -> + 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> Csyntax.type0 -> + Csyntax.type0 -> classify_sub_cases -> 'a1 + +val classify_sub_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_sub_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_sub_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_sub_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_sub_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (Nat.nat Types.option -> Nat.nat Types.option -> Csyntax.type0 -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_sub_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> classify_sub_cases + -> __ + +val classify_sub_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases -> classify_sub_cases + -> __ + +val classify_sub : Csyntax.type0 -> Csyntax.type0 -> classify_sub_cases + +type classify_aop_cases = +| Aop_case_ii of AST.intsize * AST.signedness +| Aop_default of Csyntax.type0 * Csyntax.type0 + +val classify_aop_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 + +val classify_aop_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 + +val classify_aop_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 + +val classify_aop_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 + +val classify_aop_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 + +val classify_aop_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> 'a1) -> Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> 'a1 + +val classify_aop_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_aop_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_aop_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_aop_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_aop_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_aop_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> classify_aop_cases + -> __ + +val classify_aop_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases -> classify_aop_cases + -> __ + +val classify_aop : Csyntax.type0 -> Csyntax.type0 -> classify_aop_cases + +type classify_cmp_cases = +| Cmp_case_ii of AST.intsize * AST.signedness +| Cmp_case_pp of Nat.nat Types.option * Csyntax.type0 +| Cmp_default of Csyntax.type0 * Csyntax.type0 + +val classify_cmp_cases_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 + +val classify_cmp_cases_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 + +val classify_cmp_cases_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 + +val classify_cmp_cases_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 + +val classify_cmp_cases_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 + +val classify_cmp_cases_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 -> 'a1) -> + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> 'a1 + +val classify_cmp_cases_inv_rect_Type4 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_cmp_cases_inv_rect_Type3 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_cmp_cases_inv_rect_Type2 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_cmp_cases_inv_rect_Type1 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_cmp_cases_inv_rect_Type0 : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (Nat.nat Types.option -> + Csyntax.type0 -> __ -> __ -> __ -> 'a1) -> (Csyntax.type0 -> Csyntax.type0 + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val classify_cmp_cases_discr : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> classify_cmp_cases + -> __ + +val classify_cmp_cases_jmdiscr : + Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases -> classify_cmp_cases + -> __ + +val classify_cmp : Csyntax.type0 -> Csyntax.type0 -> classify_cmp_cases + +type classify_fun_cases = +| Fun_case_f of Csyntax.typelist * Csyntax.type0 +| Fun_default + +val classify_fun_cases_rect_Type4 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases -> + 'a1 + +val classify_fun_cases_rect_Type5 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases -> + 'a1 + +val classify_fun_cases_rect_Type3 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases -> + 'a1 + +val classify_fun_cases_rect_Type2 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases -> + 'a1 + +val classify_fun_cases_rect_Type1 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases -> + 'a1 + +val classify_fun_cases_rect_Type0 : + (Csyntax.typelist -> Csyntax.type0 -> 'a1) -> 'a1 -> classify_fun_cases -> + 'a1 + +val classify_fun_cases_inv_rect_Type4 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val classify_fun_cases_inv_rect_Type3 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val classify_fun_cases_inv_rect_Type2 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val classify_fun_cases_inv_rect_Type1 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val classify_fun_cases_inv_rect_Type0 : + classify_fun_cases -> (Csyntax.typelist -> Csyntax.type0 -> __ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val classify_fun_cases_discr : classify_fun_cases -> classify_fun_cases -> __ + +val classify_fun_cases_jmdiscr : + classify_fun_cases -> classify_fun_cases -> __ + +val classify_fun : Csyntax.type0 -> classify_fun_cases + diff --git a/extracted/clight_abstract.ml b/extracted/clight_abstract.ml new file mode 100644 index 0000000..aec19fe --- /dev/null +++ b/extracted/clight_abstract.ml @@ -0,0 +1,179 @@ +open Preamble + +open TypeComparison + +open ClassifyOp + +open Events + +open Smallstep + +open CostLabel + +open Csyntax + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Csem + +(** val clight_labelled : Csem.state -> Bool.bool **) +let clight_labelled = function +| Csem.State (f, s0, k, e, m) -> + (match s0 with + | Csyntax.Sskip -> Bool.False + | Csyntax.Sassign (x, x0) -> Bool.False + | Csyntax.Scall (x, x0, x1) -> Bool.False + | Csyntax.Ssequence (x, x0) -> Bool.False + | Csyntax.Sifthenelse (x, x0, x1) -> Bool.False + | Csyntax.Swhile (x, x0) -> Bool.False + | Csyntax.Sdowhile (x, x0) -> Bool.False + | Csyntax.Sfor (x, x0, x1, x2) -> Bool.False + | Csyntax.Sbreak -> Bool.False + | Csyntax.Scontinue -> Bool.False + | Csyntax.Sreturn x -> Bool.False + | Csyntax.Sswitch (x, x0) -> Bool.False + | Csyntax.Slabel (x, x0) -> Bool.False + | Csyntax.Sgoto x -> Bool.False + | Csyntax.Scost (x, x0) -> Bool.True) +| Csem.Callstate (x, x0, x1, x2, x3) -> Bool.False +| Csem.Returnstate (x, x0, x1) -> Bool.False +| Csem.Finalstate x -> Bool.False + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +(** val clight_classify : Csem.state -> StructuredTraces.status_class **) +let clight_classify = function +| Csem.State (x, x0, x1, x2, x3) -> StructuredTraces.Cl_other +| Csem.Callstate (x, x0, x1, x2, x3) -> StructuredTraces.Cl_call +| Csem.Returnstate (x, x0, x1) -> StructuredTraces.Cl_return +| Csem.Finalstate x -> StructuredTraces.Cl_other + +type clight_state = Csem.state + +type cl_genv = Csem.genv + +type cl_env = Csem.env + +type cl_cont = Csem.cont + +(** val clState : + Csyntax.function0 -> Csyntax.statement -> Csem.cont -> Csem.env -> + GenMem.mem -> Csem.state **) +let clState x x0 x1 x2 x3 = + Csem.State (x, x0, x1, x2, x3) + +(** val clReturnstate : + Values.val0 -> Csem.cont -> GenMem.mem -> Csem.state **) +let clReturnstate x x0 x1 = + Csem.Returnstate (x, x0, x1) + +(** val clCallstate : + AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> Csem.cont + -> GenMem.mem -> Csem.state **) +let clCallstate x x0 x1 x2 x3 = + Csem.Callstate (x, x0, x1, x2, x3) + +(** val clKseq : Csyntax.statement -> Csem.cont -> Csem.cont **) +let clKseq x x0 = + Csem.Kseq (x, x0) + diff --git a/extracted/clight_abstract.mli b/extracted/clight_abstract.mli new file mode 100644 index 0000000..a57d51d --- /dev/null +++ b/extracted/clight_abstract.mli @@ -0,0 +1,144 @@ +open Preamble + +open TypeComparison + +open ClassifyOp + +open Events + +open Smallstep + +open CostLabel + +open Csyntax + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Csem + +val clight_labelled : Csem.state -> Bool.bool + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +val clight_classify : Csem.state -> StructuredTraces.status_class + +type clight_state = Csem.state + +type cl_genv = Csem.genv + +type cl_env = Csem.env + +type cl_cont = Csem.cont + +val clState : + Csyntax.function0 -> Csyntax.statement -> Csem.cont -> Csem.env -> + GenMem.mem -> Csem.state + +val clReturnstate : Values.val0 -> Csem.cont -> GenMem.mem -> Csem.state + +val clCallstate : + AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> Csem.cont -> + GenMem.mem -> Csem.state + +val clKseq : Csyntax.statement -> Csem.cont -> Csem.cont + diff --git a/extracted/clight_classified_system.ml b/extracted/clight_classified_system.ml new file mode 100644 index 0000000..7051821 --- /dev/null +++ b/extracted/clight_classified_system.ml @@ -0,0 +1,151 @@ +open Preamble + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open TypeComparison + +open ClassifyOp + +open Events + +open Smallstep + +open CostLabel + +open Csyntax + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Csem + +open Clight_abstract + +open SmallstepExec + +open Cexec + +open Stacksize + +open Executions + +open Measurable + +(** val clight_stack_ident : + Clight_abstract.cl_genv -> Clight_abstract.clight_state -> AST.ident **) +let clight_stack_ident ge s = + (match s with + | Csem.State (x, x0, x1, x2, x3) -> + (fun _ -> assert false (* absurd case *)) + | Csem.Callstate (id, x, x0, x1, x2) -> (fun _ -> id) + | Csem.Returnstate (x, x0, x1) -> + (fun _ -> assert false (* absurd case *)) + | Csem.Finalstate x -> (fun _ -> assert false (* absurd case *))) __ + +(** val clight_pcs : Measurable.preclassified_system **) +let clight_pcs = + { Measurable.pcs_exec = Cexec.clight_fullexec; Measurable.pcs_labelled = + (fun x -> Obj.magic Clight_abstract.clight_labelled); + Measurable.pcs_classify = (fun x -> + Obj.magic Clight_abstract.clight_classify); Measurable.pcs_callee = + (Obj.magic (fun x x0 _ -> clight_stack_ident x x0)) } + diff --git a/extracted/clight_classified_system.mli b/extracted/clight_classified_system.mli new file mode 100644 index 0000000..048fddd --- /dev/null +++ b/extracted/clight_classified_system.mli @@ -0,0 +1,137 @@ +open Preamble + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open TypeComparison + +open ClassifyOp + +open Events + +open Smallstep + +open CostLabel + +open Csyntax + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Csem + +open Clight_abstract + +open SmallstepExec + +open Cexec + +open Stacksize + +open Executions + +open Measurable + +val clight_stack_ident : + Clight_abstract.cl_genv -> Clight_abstract.clight_state -> AST.ident + +val clight_pcs : Measurable.preclassified_system + diff --git a/extracted/cminor_abstract.ml b/extracted/cminor_abstract.ml new file mode 100644 index 0000000..32ddda8 --- /dev/null +++ b/extracted/cminor_abstract.ml @@ -0,0 +1,180 @@ +open Preamble + +open FrontEndOps + +open Cminor_syntax + +open SmallstepExec + +open Extra_bool + +open Globalenvs + +open IOMonad + +open IO + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +open Cminor_semantics + +type cminor_state = Cminor_semantics.state + +(** val cminor_labelled : Cminor_semantics.state -> Bool.bool **) +let cminor_labelled = function +| Cminor_semantics.State (x, st, x0, x3, x4, x5, x7) -> + (match st with + | Cminor_syntax.St_skip -> Bool.False + | Cminor_syntax.St_assign (x8, x9, x10) -> Bool.False + | Cminor_syntax.St_store (x8, x9, x10) -> Bool.False + | Cminor_syntax.St_call (x8, x9, x10) -> Bool.False + | Cminor_syntax.St_seq (x8, x9) -> Bool.False + | Cminor_syntax.St_ifthenelse (x8, x9, x10, x11, x12) -> Bool.False + | Cminor_syntax.St_return x8 -> Bool.False + | Cminor_syntax.St_label (x8, x9) -> Bool.False + | Cminor_syntax.St_goto x8 -> Bool.False + | Cminor_syntax.St_cost (x8, x9) -> Bool.True) +| Cminor_semantics.Callstate (x, x0, x1, x2, x3) -> Bool.False +| Cminor_semantics.Returnstate (x, x0, x1) -> Bool.False +| Cminor_semantics.Finalstate x -> Bool.False + +open Sets + +open Listb + +open StructuredTraces + +(** val cminor_classify : + Cminor_semantics.state -> StructuredTraces.status_class **) +let cminor_classify = function +| Cminor_semantics.State (x, x0, x1, x4, x5, x6, x8) -> + StructuredTraces.Cl_other +| Cminor_semantics.Callstate (x, x0, x1, x2, x3) -> StructuredTraces.Cl_call +| Cminor_semantics.Returnstate (x, x0, x1) -> StructuredTraces.Cl_return +| Cminor_semantics.Finalstate x -> StructuredTraces.Cl_other + +type cm_genv = Cminor_semantics.genv + +type cm_env = Cminor_semantics.env + +type cm_cont = Cminor_semantics.cont + +(** val cm_eval_expr : + Cminor_semantics.genv -> AST.typ -> Cminor_syntax.expr -> + Cminor_semantics.env -> Pointers.block -> GenMem.mem -> (Events.trace, + Values.val0) Types.prod Errors.res **) +let cm_eval_expr ge ty0 e en sp m = + Cminor_semantics.eval_expr ge ty0 e en sp m + +(** val cmState : + Cminor_syntax.internal_function -> Cminor_syntax.stmt -> + Cminor_semantics.env -> GenMem.mem -> Pointers.block -> + Cminor_semantics.cont -> Cminor_semantics.stack -> Cminor_semantics.state **) +let cmState f s en m sp k st = + Cminor_semantics.State (f, s, en, m, sp, k, st) + +(** val cmReturnstate : + Values.val0 Types.option -> GenMem.mem -> Cminor_semantics.stack -> + Cminor_semantics.state **) +let cmReturnstate x x0 x1 = + Cminor_semantics.Returnstate (x, x0, x1) + +(** val cmCallstate : + AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> Cminor_semantics.stack -> + Cminor_semantics.state **) +let cmCallstate x x0 x1 x2 x3 = + Cminor_semantics.Callstate (x, x0, x1, x2, x3) + diff --git a/extracted/cminor_abstract.mli b/extracted/cminor_abstract.mli new file mode 100644 index 0000000..8fbf87c --- /dev/null +++ b/extracted/cminor_abstract.mli @@ -0,0 +1,148 @@ +open Preamble + +open FrontEndOps + +open Cminor_syntax + +open SmallstepExec + +open Extra_bool + +open Globalenvs + +open IOMonad + +open IO + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +open Cminor_semantics + +type cminor_state = Cminor_semantics.state + +val cminor_labelled : Cminor_semantics.state -> Bool.bool + +open Sets + +open Listb + +open StructuredTraces + +val cminor_classify : Cminor_semantics.state -> StructuredTraces.status_class + +type cm_genv = Cminor_semantics.genv + +type cm_env = Cminor_semantics.env + +type cm_cont = Cminor_semantics.cont + +val cm_eval_expr : + Cminor_semantics.genv -> AST.typ -> Cminor_syntax.expr -> + Cminor_semantics.env -> Pointers.block -> GenMem.mem -> (Events.trace, + Values.val0) Types.prod Errors.res + +val cmState : + Cminor_syntax.internal_function -> Cminor_syntax.stmt -> + Cminor_semantics.env -> GenMem.mem -> Pointers.block -> + Cminor_semantics.cont -> Cminor_semantics.stack -> Cminor_semantics.state + +val cmReturnstate : + Values.val0 Types.option -> GenMem.mem -> Cminor_semantics.stack -> + Cminor_semantics.state + +val cmCallstate : + AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> Cminor_semantics.stack -> Cminor_semantics.state + diff --git a/extracted/cminor_classified_system.ml b/extracted/cminor_classified_system.ml new file mode 100644 index 0000000..2c2b044 --- /dev/null +++ b/extracted/cminor_classified_system.ml @@ -0,0 +1,147 @@ +open Preamble + +open Sets + +open Listb + +open StructuredTraces + +open FrontEndOps + +open Cminor_syntax + +open SmallstepExec + +open Extra_bool + +open Globalenvs + +open IOMonad + +open IO + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +open Cminor_semantics + +open Cminor_abstract + +open Stacksize + +open Executions + +open Measurable + +(** val cminor_stack_ident : + Cminor_semantics.genv -> Cminor_abstract.cminor_state -> AST.ident **) +let cminor_stack_ident ge s = + (match s with + | Cminor_semantics.State (x, x0, x1, x4, x5, x6, x8) -> + (fun _ -> assert false (* absurd case *)) + | Cminor_semantics.Callstate (id, x, x0, x1, x2) -> (fun _ -> id) + | Cminor_semantics.Returnstate (x, x0, x1) -> + (fun _ -> assert false (* absurd case *)) + | Cminor_semantics.Finalstate x -> + (fun _ -> assert false (* absurd case *))) __ + +(** val cminor_pcs : Measurable.preclassified_system **) +let cminor_pcs = + { Measurable.pcs_exec = Cminor_semantics.cminor_fullexec; + Measurable.pcs_labelled = (fun x -> + Obj.magic Cminor_abstract.cminor_labelled); Measurable.pcs_classify = + (fun x -> Obj.magic Cminor_abstract.cminor_classify); + Measurable.pcs_callee = + (Obj.magic (fun x x0 _ -> cminor_stack_ident x x0)) } + diff --git a/extracted/cminor_classified_system.mli b/extracted/cminor_classified_system.mli new file mode 100644 index 0000000..77ea3f2 --- /dev/null +++ b/extracted/cminor_classified_system.mli @@ -0,0 +1,131 @@ +open Preamble + +open Sets + +open Listb + +open StructuredTraces + +open FrontEndOps + +open Cminor_syntax + +open SmallstepExec + +open Extra_bool + +open Globalenvs + +open IOMonad + +open IO + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +open Cminor_semantics + +open Cminor_abstract + +open Stacksize + +open Executions + +open Measurable + +val cminor_stack_ident : + Cminor_semantics.genv -> Cminor_abstract.cminor_state -> AST.ident + +val cminor_pcs : Measurable.preclassified_system + diff --git a/extracted/cminor_semantics.ml b/extracted/cminor_semantics.ml new file mode 100644 index 0000000..d06f05f --- /dev/null +++ b/extracted/cminor_semantics.ml @@ -0,0 +1,929 @@ +open Preamble + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open IOMonad + +open IO + +open Extra_bool + +open Globalenvs + +open SmallstepExec + +open FrontEndOps + +open Cminor_syntax + +type env = Values.val0 Identifiers.identifier_map + +type genv = Cminor_syntax.internal_function AST.fundef Globalenvs.genv_t + +type cont = +| Kend +| Kseq of Cminor_syntax.stmt * cont +| Kblock of cont + +(** val cont_rect_Type4 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 **) +let rec cont_rect_Type4 h_Kend h_Kseq h_Kblock = function +| Kend -> h_Kend +| Kseq (x_23729, x_23728) -> + h_Kseq x_23729 x_23728 (cont_rect_Type4 h_Kend h_Kseq h_Kblock x_23728) +| Kblock x_23730 -> + h_Kblock x_23730 (cont_rect_Type4 h_Kend h_Kseq h_Kblock x_23730) + +(** val cont_rect_Type3 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 **) +let rec cont_rect_Type3 h_Kend h_Kseq h_Kblock = function +| Kend -> h_Kend +| Kseq (x_23743, x_23742) -> + h_Kseq x_23743 x_23742 (cont_rect_Type3 h_Kend h_Kseq h_Kblock x_23742) +| Kblock x_23744 -> + h_Kblock x_23744 (cont_rect_Type3 h_Kend h_Kseq h_Kblock x_23744) + +(** val cont_rect_Type2 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 **) +let rec cont_rect_Type2 h_Kend h_Kseq h_Kblock = function +| Kend -> h_Kend +| Kseq (x_23750, x_23749) -> + h_Kseq x_23750 x_23749 (cont_rect_Type2 h_Kend h_Kseq h_Kblock x_23749) +| Kblock x_23751 -> + h_Kblock x_23751 (cont_rect_Type2 h_Kend h_Kseq h_Kblock x_23751) + +(** val cont_rect_Type1 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 **) +let rec cont_rect_Type1 h_Kend h_Kseq h_Kblock = function +| Kend -> h_Kend +| Kseq (x_23757, x_23756) -> + h_Kseq x_23757 x_23756 (cont_rect_Type1 h_Kend h_Kseq h_Kblock x_23756) +| Kblock x_23758 -> + h_Kblock x_23758 (cont_rect_Type1 h_Kend h_Kseq h_Kblock x_23758) + +(** val cont_rect_Type0 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 **) +let rec cont_rect_Type0 h_Kend h_Kseq h_Kblock = function +| Kend -> h_Kend +| Kseq (x_23764, x_23763) -> + h_Kseq x_23764 x_23763 (cont_rect_Type0 h_Kend h_Kseq h_Kblock x_23763) +| Kblock x_23765 -> + h_Kblock x_23765 (cont_rect_Type0 h_Kend h_Kseq h_Kblock x_23765) + +(** val cont_inv_rect_Type4 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = cont_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val cont_inv_rect_Type3 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = cont_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val cont_inv_rect_Type2 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = cont_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val cont_inv_rect_Type1 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = cont_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val cont_inv_rect_Type0 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = cont_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val cont_discr : cont -> cont -> __ **) +let cont_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Kend -> Obj.magic (fun _ dH -> dH) + | Kseq (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Kblock a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val cont_jmdiscr : cont -> cont -> __ **) +let cont_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Kend -> Obj.magic (fun _ dH -> dH) + | Kseq (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Kblock a0 -> Obj.magic (fun _ dH -> dH __)) y + +type stack = +| SStop +| Scall of (AST.ident, AST.typ) Types.prod Types.option + * Cminor_syntax.internal_function * Pointers.block * env * cont * + stack + +(** val stack_rect_Type4 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 **) +let rec stack_rect_Type4 h_SStop h_Scall = function +| SStop -> h_SStop +| Scall (dest, f, x_23824, en, k, x_23820) -> + h_Scall dest f x_23824 en __ __ k __ x_23820 + (stack_rect_Type4 h_SStop h_Scall x_23820) + +(** val stack_rect_Type3 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 **) +let rec stack_rect_Type3 h_SStop h_Scall = function +| SStop -> h_SStop +| Scall (dest, f, x_23840, en, k, x_23836) -> + h_Scall dest f x_23840 en __ __ k __ x_23836 + (stack_rect_Type3 h_SStop h_Scall x_23836) + +(** val stack_rect_Type2 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 **) +let rec stack_rect_Type2 h_SStop h_Scall = function +| SStop -> h_SStop +| Scall (dest, f, x_23848, en, k, x_23844) -> + h_Scall dest f x_23848 en __ __ k __ x_23844 + (stack_rect_Type2 h_SStop h_Scall x_23844) + +(** val stack_rect_Type1 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 **) +let rec stack_rect_Type1 h_SStop h_Scall = function +| SStop -> h_SStop +| Scall (dest, f, x_23856, en, k, x_23852) -> + h_Scall dest f x_23856 en __ __ k __ x_23852 + (stack_rect_Type1 h_SStop h_Scall x_23852) + +(** val stack_rect_Type0 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 **) +let rec stack_rect_Type0 h_SStop h_Scall = function +| SStop -> h_SStop +| Scall (dest, f, x_23864, en, k, x_23860) -> + h_Scall dest f x_23864 en __ __ k __ x_23860 + (stack_rect_Type0 h_SStop h_Scall x_23860) + +(** val stack_inv_rect_Type4 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stack_inv_rect_Type4 hterm h1 h2 = + let hcut = stack_rect_Type4 h1 h2 hterm in hcut __ + +(** val stack_inv_rect_Type3 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stack_inv_rect_Type3 hterm h1 h2 = + let hcut = stack_rect_Type3 h1 h2 hterm in hcut __ + +(** val stack_inv_rect_Type2 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stack_inv_rect_Type2 hterm h1 h2 = + let hcut = stack_rect_Type2 h1 h2 hterm in hcut __ + +(** val stack_inv_rect_Type1 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stack_inv_rect_Type1 hterm h1 h2 = + let hcut = stack_rect_Type1 h1 h2 hterm in hcut __ + +(** val stack_inv_rect_Type0 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stack_inv_rect_Type0 hterm h1 h2 = + let hcut = stack_rect_Type0 h1 h2 hterm in hcut __ + +(** val stack_jmdiscr : stack -> stack -> __ **) +let stack_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | SStop -> Obj.magic (fun _ dH -> dH) + | Scall (a0, a1, a2, a3, a6, a8) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __)) y + +type state = +| State of Cminor_syntax.internal_function * Cminor_syntax.stmt * env + * GenMem.mem * Pointers.block * cont * stack +| Callstate of AST.ident * Cminor_syntax.internal_function AST.fundef + * Values.val0 List.list * GenMem.mem * stack +| Returnstate of Values.val0 Types.option * GenMem.mem * stack +| Finalstate of Integers.int + +(** val state_rect_Type4 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type4 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, en, m, sp, k, st) -> h_State f s en __ __ m sp k __ st +| Callstate (id, fd, args, m, st) -> h_Callstate id fd args m st +| Returnstate (v, m, st) -> h_Returnstate v m st +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type5 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type5 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, en, m, sp, k, st) -> h_State f s en __ __ m sp k __ st +| Callstate (id, fd, args, m, st) -> h_Callstate id fd args m st +| Returnstate (v, m, st) -> h_Returnstate v m st +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type3 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type3 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, en, m, sp, k, st) -> h_State f s en __ __ m sp k __ st +| Callstate (id, fd, args, m, st) -> h_Callstate id fd args m st +| Returnstate (v, m, st) -> h_Returnstate v m st +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type2 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type2 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, en, m, sp, k, st) -> h_State f s en __ __ m sp k __ st +| Callstate (id, fd, args, m, st) -> h_Callstate id fd args m st +| Returnstate (v, m, st) -> h_Returnstate v m st +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type1 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type1 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, en, m, sp, k, st) -> h_State f s en __ __ m sp k __ st +| Callstate (id, fd, args, m, st) -> h_Callstate id fd args m st +| Returnstate (v, m, st) -> h_Returnstate v m st +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type0 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type0 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, en, m, sp, k, st) -> h_State f s en __ __ m sp k __ st +| Callstate (id, fd, args, m, st) -> h_Callstate id fd args m st +| Returnstate (v, m, st) -> h_Returnstate v m st +| Finalstate r -> h_Finalstate r + +(** val state_inv_rect_Type4 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> + (Values.val0 Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type3 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> + (Values.val0 Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type2 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> + (Values.val0 Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type1 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> + (Values.val0 Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type0 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> + (Values.val0 Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val state_jmdiscr : state -> state -> __ **) +let state_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | State (a0, a1, a2, a5, a6, a7, a9) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __) + | Callstate (a0, a1, a2, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | Returnstate (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Finalstate a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val eval_expr : + genv -> AST.typ -> Cminor_syntax.expr -> env -> Pointers.block -> + GenMem.mem -> (Events.trace, Values.val0) Types.prod Errors.res **) +let rec eval_expr ge ty0 e en sp m = + (match e with + | Cminor_syntax.Id (x, i) -> + (fun _ -> + let r = Identifiers.lookup_present PreIdentifiers.SymbolTag en i in + Errors.OK { Types.fst = Events.e0; Types.snd = r }) + | Cminor_syntax.Cst (x, c) -> + (fun _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedConstant) + (FrontEndOps.eval_constant x (Globalenvs.find_symbol ge) sp c))) + (fun r -> + Obj.magic (Errors.OK { Types.fst = Events.e0; Types.snd = r })))) + | Cminor_syntax.Op1 (ty, ty', op, e') -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge ty e' en sp m)) (fun tr v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_unop ty ty' op v))) (fun r -> + Obj.magic (Errors.OK { Types.fst = tr; Types.snd = r }))))) + | Cminor_syntax.Op2 (ty1, ty2, ty', op, e1, e2) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge ty1 e1 en sp m)) (fun tr1 v1 -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge ty2 e2 en sp m)) (fun tr2 v2 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_binop m ty1 ty2 ty' op v1 v2))) + (fun r -> + Obj.magic (Errors.OK { Types.fst = (Events.eapp tr1 tr2); + Types.snd = r })))))) + | Cminor_syntax.Mem (ty, e0) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge AST.ASTptr e0 en sp m)) (fun tr v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (FrontEndMem.loadv ty m v))) (fun r -> + Obj.magic (Errors.OK { Types.fst = tr; Types.snd = r }))))) + | Cminor_syntax.Cond (sz, sg, ty, e', e1, e2) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge (AST.ASTint (sz, sg)) e' en sp m)) + (fun tr v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Values.eval_bool_of_val v)) (fun b -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (eval_expr ge ty + (match b with + | Bool.True -> e1 + | Bool.False -> e2) en sp m)) (fun tr' r -> + Obj.magic (Errors.OK { Types.fst = (Events.eapp tr tr'); + Types.snd = r })))))) + | Cminor_syntax.Ecost (ty, l, e') -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge ty e' en sp m)) (fun tr r -> + Obj.magic (Errors.OK { Types.fst = + (Events.eapp (Events.echarge l) tr); Types.snd = r }))))) __ + +(** val k_exit : + Nat.nat -> cont -> Cminor_syntax.internal_function -> env -> cont + Types.sig0 Errors.res **) +let rec k_exit n k f en = + (match k with + | Kend -> (fun _ -> Errors.Error (Errors.msg ErrorMessages.BadState)) + | Kseq (x, k') -> (fun _ -> k_exit n k' f en) + | Kblock k' -> + (fun _ -> + match n with + | Nat.O -> Errors.OK k' + | Nat.S m -> k_exit m k' f en)) __ + +(** val find_case : + AST.intsize -> AST.bvint -> (AST.bvint, 'a1) Types.prod List.list -> 'a1 + -> 'a1 **) +let rec find_case sz i cs default = + match cs with + | List.Nil -> default + | List.Cons (h, t) -> + let { Types.fst = hi; Types.snd = a } = h in + (match BitVector.eq_bv (AST.bitsize_of_intsize sz) i hi with + | Bool.True -> a + | Bool.False -> find_case sz i t default) + +(** val find_label : + PreIdentifiers.identifier -> Cminor_syntax.stmt -> cont -> + Cminor_syntax.internal_function -> env -> (Cminor_syntax.stmt, cont) + Types.prod Types.sig0 Types.option **) +let rec find_label l s k f en = + (match s with + | Cminor_syntax.St_skip -> (fun _ -> Types.None) + | Cminor_syntax.St_assign (x, x0, x1) -> (fun _ -> Types.None) + | Cminor_syntax.St_store (x, x0, x1) -> (fun _ -> Types.None) + | Cminor_syntax.St_call (x, x0, x1) -> (fun _ -> Types.None) + | Cminor_syntax.St_seq (s1, s2) -> + (fun _ -> + match find_label l s1 (Kseq (s2, k)) f en with + | Types.None -> find_label l s2 k f en + | Types.Some sk -> Types.Some sk) + | Cminor_syntax.St_ifthenelse (x, x0, x1, s1, s2) -> + (fun _ -> + match find_label l s1 k f en with + | Types.None -> find_label l s2 k f en + | Types.Some sk -> Types.Some sk) + | Cminor_syntax.St_return x -> (fun _ -> Types.None) + | Cminor_syntax.St_label (l', s') -> + (fun _ -> + match Identifiers.identifier_eq PreIdentifiers.Label l l' with + | Types.Inl _ -> Types.Some { Types.fst = s'; Types.snd = k } + | Types.Inr _ -> find_label l s' k f en) + | Cminor_syntax.St_goto x -> (fun _ -> Types.None) + | Cminor_syntax.St_cost (x, s') -> (fun _ -> find_label l s' k f en)) __ + +(** val find_label_always : + PreIdentifiers.identifier -> Cminor_syntax.stmt -> cont -> + Cminor_syntax.internal_function -> env -> (Cminor_syntax.stmt, cont) + Types.prod Types.sig0 **) +let find_label_always l s k f en = + (match find_label l s k f en with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some sk -> (fun _ -> sk)) __ + +(** val bind_params : + Values.val0 List.list -> (AST.ident, AST.typ) Types.prod List.list -> env + Types.sig0 Errors.res **) +let rec bind_params vs ids = + match vs with + | List.Nil -> + (match ids with + | List.Nil -> Errors.OK (Identifiers.empty_map PreIdentifiers.SymbolTag) + | List.Cons (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.WrongNumberOfParameters)) + | List.Cons (v, vt) -> + (match ids with + | List.Nil -> + Errors.Error (Errors.msg ErrorMessages.WrongNumberOfParameters) + | List.Cons (idh, idt) -> + let { Types.fst = id; Types.snd = ty } = idh in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (bind_params vt idt)) (fun en -> + Obj.magic (Errors.OK + (Identifiers.add PreIdentifiers.SymbolTag (Types.pi1 en) + idh.Types.fst v))))) + +(** val init_locals : + env -> (AST.ident, AST.typ) Types.prod List.list -> env **) +let init_locals = + List.foldr (fun idty en -> + Identifiers.add PreIdentifiers.SymbolTag en idty.Types.fst Values.Vundef) + +(** val trace_map_inv : + ('a1 -> __ -> (Events.trace, 'a2) Types.prod Errors.res) -> 'a1 List.list + -> (Events.trace, 'a2 List.list) Types.prod Errors.res **) +let rec trace_map_inv f l = + (match l with + | List.Nil -> + (fun _ -> Errors.OK { Types.fst = Events.e0; Types.snd = List.Nil }) + | List.Cons (h, t) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) (Obj.magic f h __) + (fun tr h' -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (trace_map_inv f t)) (fun tr' t' -> + Obj.magic (Errors.OK { Types.fst = (Events.eapp tr tr'); + Types.snd = (List.Cons (h', t')) })))))) __ + +(** val eval_step : + genv -> state -> (IO.io_out, IO.io_in, (Events.trace, state) Types.prod) + IOMonad.iO **) +let eval_step ge = function +| State (f, s, en, m, sp, k, st0) -> + IOMonad.err_to_io + ((match s with + | Cminor_syntax.St_skip -> + (fun _ -> + (match k with + | Kend -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Returnstate (Types.None, + (GenMem.free m sp), st0)) })) + | Kseq (s', k') -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, s', en, m, sp, k', + st0)) })) + | Kblock k' -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, Cminor_syntax.St_skip, + en, m, sp, k', st0)) }))) __) + | Cminor_syntax.St_assign (x, id, e) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge x e en sp m)) (fun tr v -> + let en' = + Identifiers.update_present PreIdentifiers.SymbolTag en id v + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = tr; + Types.snd = (State (f, Cminor_syntax.St_skip, en', m, sp, k, + st0)) }))) + | Cminor_syntax.St_store (ty, edst, e) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge AST.ASTptr edst en sp m)) + (fun tr vdst -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge ty e en sp m)) (fun tr' v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedStore) + (FrontEndMem.storev ty m vdst v))) (fun m' -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (Events.eapp tr tr'); Types.snd = (State (f, + Cminor_syntax.St_skip, en, m', sp, k, st0)) }))))) + | Cminor_syntax.St_call (dst, ef, args) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge AST.ASTptr ef en sp m)) (fun tr vf -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res + (Errors.msg ErrorMessages.BadFunctionValue) + (Globalenvs.find_funct_id ge vf))) (fun fd id -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (trace_map_inv (fun e -> + let { Types.dpi1 = ty; Types.dpi2 = e0 } = e in + (fun _ -> eval_expr ge ty e0 en sp m)) args)) + (fun tr' vargs -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (Events.eapp tr tr'); Types.snd = (Callstate (id, fd, + vargs, m, (Scall (dst, f, sp, en, k, st0)))) }))))) + | Cminor_syntax.St_seq (s1, s2) -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, s1, en, m, sp, (Kseq (s2, + k)), st0)) })) + | Cminor_syntax.St_ifthenelse (x, x0, e, strue, sfalse) -> + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge (AST.ASTint (x, x0)) e en sp m)) + (fun tr v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Values.eval_bool_of_val v)) (fun b -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = tr; + Types.snd = (State (f, + (match b with + | Bool.True -> strue + | Bool.False -> sfalse), en, m, sp, k, st0)) })))) + | Cminor_syntax.St_return eo -> + (match eo with + | Types.None -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Returnstate (Types.None, + (GenMem.free m sp), st0)) })) + | Types.Some e -> + let { Types.dpi1 = ty; Types.dpi2 = e0 } = e in + (fun _ -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (eval_expr ge ty e0 en sp m)) (fun tr v -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = tr; + Types.snd = (Returnstate ((Types.Some v), + (GenMem.free m sp), st0)) })))) + | Cminor_syntax.St_label (l, s') -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, s', en, m, sp, k, st0)) })) + | Cminor_syntax.St_goto l -> + (fun _ -> + let sk = find_label_always l f.Cminor_syntax.f_body Kend f en in + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, sk.Types.fst, en, m, sp, + sk.Types.snd, st0)) })) + | Cminor_syntax.St_cost (l, s') -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (Events.echarge l); Types.snd = (State (f, s', en, m, sp, k, + st0)) }))) __) +| Callstate (x, fd, args, m, st0) -> + (match fd with + | AST.Internal f -> + IOMonad.err_to_io + (let { Types.fst = m'; Types.snd = sp } = + GenMem.alloc m (Z.z_of_nat Nat.O) + (Z.z_of_nat f.Cminor_syntax.f_stacksize) + in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (bind_params args f.Cminor_syntax.f_params)) (fun en -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, f.Cminor_syntax.f_body, + (init_locals (Types.pi1 en) f.Cminor_syntax.f_vars), m', sp, + Kend, st0)) }))) + | AST.External fn -> + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io + (IO.check_eventval_list args fn.AST.ef_sig.AST.sig_args))) + (fun evargs -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IO.do_io fn.AST.ef_id evargs (AST.proj_sig_res fn.AST.ef_sig))) + (fun evres -> + let res = + match fn.AST.ef_sig.AST.sig_res with + | Types.None -> Types.None + | Types.Some x0 -> + Types.Some (IO.mk_val (AST.proj_sig_res fn.AST.ef_sig) evres) + in + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { Types.fst = + (Events.eextcall fn.AST.ef_id evargs + (IO.mk_eventval (AST.proj_sig_res fn.AST.ef_sig) evres)); + Types.snd = (Returnstate (res, m, st0)) })))) +| Returnstate (result, m, st0) -> + IOMonad.err_to_io + (match st0 with + | SStop -> + (match result with + | Types.None -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch) + | Types.Some v -> + (match v with + | Values.Vundef -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch) + | Values.Vint (sz, r) -> + (match sz with + | AST.I8 -> + (fun x -> Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch)) + | AST.I16 -> + (fun x -> Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch)) + | AST.I32 -> + (fun r0 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + { Types.fst = Events.e0; Types.snd = (Finalstate r0) }))) + r + | Values.Vnull -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch) + | Values.Vptr x -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch))) + | Scall (dst, f, sp, en, k, st') -> + (match result with + | Types.None -> + (match dst with + | Types.None -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, Cminor_syntax.St_skip, en, + m, sp, k, st')) }) + | Types.Some x -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch)) + | Types.Some v -> + (match dst with + | Types.None -> + (fun _ -> Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch)) + | Types.Some idty -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State (f, Cminor_syntax.St_skip, + (Identifiers.update_present PreIdentifiers.SymbolTag en + idty.Types.fst v), m, sp, k, st')) }))) __)) +| Finalstate r -> + IOMonad.err_to_io (Errors.Error (Errors.msg ErrorMessages.BadState)) + +(** val is_final : state -> Integers.int Types.option **) +let is_final = function +| State (x, x0, x1, x4, x5, x6, x8) -> Types.None +| Callstate (x, x0, x1, x2, x3) -> Types.None +| Returnstate (x, x0, x1) -> Types.None +| Finalstate r -> Types.Some r + +(** val cminor_exec : (IO.io_out, IO.io_in) SmallstepExec.trans_system **) +let cminor_exec = + { SmallstepExec.is_final = (fun x -> Obj.magic is_final); + SmallstepExec.step = (Obj.magic eval_step) } + +(** val make_global : Cminor_syntax.cminor_program -> genv **) +let make_global p = + Globalenvs.globalenv (fun x -> x) p + +(** val make_initial_state : + Cminor_syntax.cminor_program -> state Errors.res **) +let make_initial_state p = + let ge = make_global p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Globalenvs.init_mem (fun x -> x) p)) (fun m -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.MainMissing) + (Globalenvs.find_symbol ge p.AST.prog_main))) (fun b -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.MainMissing) + (Globalenvs.find_funct_ptr ge b))) (fun f -> + Obj.magic (Errors.OK (Callstate (p.AST.prog_main, f, List.Nil, m, + SStop))))))) + +(** val cminor_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let cminor_fullexec = + { SmallstepExec.es1 = cminor_exec; SmallstepExec.make_global = + (Obj.magic make_global); SmallstepExec.make_initial_state = + (Obj.magic make_initial_state) } + +(** val make_noinit_global : Cminor_syntax.cminor_noinit_program -> genv **) +let make_noinit_global p = + Globalenvs.globalenv (fun x -> List.Cons ((AST.Init_space x), List.Nil)) p + +(** val make_initial_noinit_state : + Cminor_syntax.cminor_noinit_program -> state Errors.res **) +let make_initial_noinit_state p = + let ge = make_noinit_global p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Globalenvs.init_mem (fun x -> List.Cons ((AST.Init_space x), + List.Nil)) p)) (fun m -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.MainMissing) + (Globalenvs.find_symbol ge p.AST.prog_main))) (fun b -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.MainMissing) + (Globalenvs.find_funct_ptr ge b))) (fun f -> + Obj.magic (Errors.OK (Callstate (p.AST.prog_main, f, List.Nil, m, + SStop))))))) + +(** val cminor_noinit_fullexec : + (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let cminor_noinit_fullexec = + { SmallstepExec.es1 = cminor_exec; SmallstepExec.make_global = + (Obj.magic make_noinit_global); SmallstepExec.make_initial_state = + (Obj.magic make_initial_noinit_state) } + diff --git a/extracted/cminor_semantics.mli b/extracted/cminor_semantics.mli new file mode 100644 index 0000000..08ac0e8 --- /dev/null +++ b/extracted/cminor_semantics.mli @@ -0,0 +1,366 @@ +open Preamble + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open IOMonad + +open IO + +open Extra_bool + +open Globalenvs + +open SmallstepExec + +open FrontEndOps + +open Cminor_syntax + +type env = Values.val0 Identifiers.identifier_map + +type genv = Cminor_syntax.internal_function AST.fundef Globalenvs.genv_t + +type cont = +| Kend +| Kseq of Cminor_syntax.stmt * cont +| Kblock of cont + +val cont_rect_Type4 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 + +val cont_rect_Type3 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 + +val cont_rect_Type2 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 + +val cont_rect_Type1 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 + +val cont_rect_Type0 : + 'a1 -> (Cminor_syntax.stmt -> cont -> 'a1 -> 'a1) -> (cont -> 'a1 -> 'a1) + -> cont -> 'a1 + +val cont_inv_rect_Type4 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type3 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type2 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type1 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type0 : + cont -> (__ -> 'a1) -> (Cminor_syntax.stmt -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_discr : cont -> cont -> __ + +val cont_jmdiscr : cont -> cont -> __ + +type stack = +| SStop +| Scall of (AST.ident, AST.typ) Types.prod Types.option + * Cminor_syntax.internal_function * Pointers.block * env * cont * + stack + +val stack_rect_Type4 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 + +val stack_rect_Type3 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 + +val stack_rect_Type2 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 + +val stack_rect_Type1 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 + +val stack_rect_Type0 : + 'a1 -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> 'a1 -> 'a1) -> stack -> 'a1 + +val stack_inv_rect_Type4 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stack_inv_rect_Type3 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stack_inv_rect_Type2 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stack_inv_rect_Type1 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stack_inv_rect_Type0 : + stack -> (__ -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> + Cminor_syntax.internal_function -> Pointers.block -> env -> __ -> __ -> + cont -> __ -> stack -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stack_jmdiscr : stack -> stack -> __ + +type state = +| State of Cminor_syntax.internal_function * Cminor_syntax.stmt * env + * GenMem.mem * Pointers.block * cont * stack +| Callstate of AST.ident * Cminor_syntax.internal_function AST.fundef + * Values.val0 List.list * GenMem.mem * stack +| Returnstate of Values.val0 Types.option * GenMem.mem * stack +| Finalstate of Integers.int + +val state_rect_Type4 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type5 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type3 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type2 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type1 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type0 : + (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> __ -> __ + -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> 'a1) -> + (AST.ident -> Cminor_syntax.internal_function AST.fundef -> Values.val0 + List.list -> GenMem.mem -> stack -> 'a1) -> (Values.val0 Types.option -> + GenMem.mem -> stack -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_inv_rect_Type4 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> (Values.val0 + Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> (Integers.int -> __ -> + 'a1) -> 'a1 + +val state_inv_rect_Type3 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> (Values.val0 + Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> (Integers.int -> __ -> + 'a1) -> 'a1 + +val state_inv_rect_Type2 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> (Values.val0 + Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> (Integers.int -> __ -> + 'a1) -> 'a1 + +val state_inv_rect_Type1 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> (Values.val0 + Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> (Integers.int -> __ -> + 'a1) -> 'a1 + +val state_inv_rect_Type0 : + state -> (Cminor_syntax.internal_function -> Cminor_syntax.stmt -> env -> + __ -> __ -> GenMem.mem -> Pointers.block -> cont -> __ -> stack -> __ -> + 'a1) -> (AST.ident -> Cminor_syntax.internal_function AST.fundef -> + Values.val0 List.list -> GenMem.mem -> stack -> __ -> 'a1) -> (Values.val0 + Types.option -> GenMem.mem -> stack -> __ -> 'a1) -> (Integers.int -> __ -> + 'a1) -> 'a1 + +val state_jmdiscr : state -> state -> __ + +val eval_expr : + genv -> AST.typ -> Cminor_syntax.expr -> env -> Pointers.block -> + GenMem.mem -> (Events.trace, Values.val0) Types.prod Errors.res + +val k_exit : + Nat.nat -> cont -> Cminor_syntax.internal_function -> env -> cont + Types.sig0 Errors.res + +val find_case : + AST.intsize -> AST.bvint -> (AST.bvint, 'a1) Types.prod List.list -> 'a1 -> + 'a1 + +val find_label : + PreIdentifiers.identifier -> Cminor_syntax.stmt -> cont -> + Cminor_syntax.internal_function -> env -> (Cminor_syntax.stmt, cont) + Types.prod Types.sig0 Types.option + +val find_label_always : + PreIdentifiers.identifier -> Cminor_syntax.stmt -> cont -> + Cminor_syntax.internal_function -> env -> (Cminor_syntax.stmt, cont) + Types.prod Types.sig0 + +val bind_params : + Values.val0 List.list -> (AST.ident, AST.typ) Types.prod List.list -> env + Types.sig0 Errors.res + +val init_locals : env -> (AST.ident, AST.typ) Types.prod List.list -> env + +val trace_map_inv : + ('a1 -> __ -> (Events.trace, 'a2) Types.prod Errors.res) -> 'a1 List.list + -> (Events.trace, 'a2 List.list) Types.prod Errors.res + +val eval_step : + genv -> state -> (IO.io_out, IO.io_in, (Events.trace, state) Types.prod) + IOMonad.iO + +val is_final : state -> Integers.int Types.option + +val cminor_exec : (IO.io_out, IO.io_in) SmallstepExec.trans_system + +val make_global : Cminor_syntax.cminor_program -> genv + +val make_initial_state : Cminor_syntax.cminor_program -> state Errors.res + +val cminor_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec + +val make_noinit_global : Cminor_syntax.cminor_noinit_program -> genv + +val make_initial_noinit_state : + Cminor_syntax.cminor_noinit_program -> state Errors.res + +val cminor_noinit_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec + diff --git a/extracted/cminor_syntax.ml b/extracted/cminor_syntax.ml new file mode 100644 index 0000000..7017544 --- /dev/null +++ b/extracted/cminor_syntax.ml @@ -0,0 +1,892 @@ +open Preamble + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +type expr = +| Id of AST.typ * AST.ident +| Cst of AST.typ * FrontEndOps.constant +| Op1 of AST.typ * AST.typ * FrontEndOps.unary_operation * expr +| Op2 of AST.typ * AST.typ * AST.typ * FrontEndOps.binary_operation * + expr * expr +| Mem of AST.typ * expr +| Cond of AST.intsize * AST.signedness * AST.typ * expr * expr * expr +| Ecost of AST.typ * CostLabel.costlabel * expr + +(** val expr_rect_Type4 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 + -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 + -> 'a1) -> AST.typ -> expr -> 'a1 **) +let rec expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost x_13742 = function +| Id (t, x_13744) -> h_Id t x_13744 +| Cst (t, x_13745) -> h_Cst t x_13745 +| Op1 (t, t', x_13747, x_13746) -> + h_Op1 t t' x_13747 x_13746 + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13746) +| Op2 (t1, t2, t', x_13750, x_13749, x_13748) -> + h_Op2 t1 t2 t' x_13750 x_13749 x_13748 + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t1 x_13749) + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t2 x_13748) +| Mem (t, x_13751) -> + h_Mem t x_13751 + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost AST.ASTptr + x_13751) +| Cond (sz, sg, t, x_13754, x_13753, x_13752) -> + h_Cond sz sg t x_13754 x_13753 x_13752 + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost (AST.ASTint + (sz, sg)) x_13754) + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13753) + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13752) +| Ecost (t, x_13756, x_13755) -> + h_Ecost t x_13756 x_13755 + (expr_rect_Type4 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13755) + +(** val expr_rect_Type3 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 + -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 + -> 'a1) -> AST.typ -> expr -> 'a1 **) +let rec expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost x_13786 = function +| Id (t, x_13788) -> h_Id t x_13788 +| Cst (t, x_13789) -> h_Cst t x_13789 +| Op1 (t, t', x_13791, x_13790) -> + h_Op1 t t' x_13791 x_13790 + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13790) +| Op2 (t1, t2, t', x_13794, x_13793, x_13792) -> + h_Op2 t1 t2 t' x_13794 x_13793 x_13792 + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t1 x_13793) + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t2 x_13792) +| Mem (t, x_13795) -> + h_Mem t x_13795 + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost AST.ASTptr + x_13795) +| Cond (sz, sg, t, x_13798, x_13797, x_13796) -> + h_Cond sz sg t x_13798 x_13797 x_13796 + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost (AST.ASTint + (sz, sg)) x_13798) + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13797) + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13796) +| Ecost (t, x_13800, x_13799) -> + h_Ecost t x_13800 x_13799 + (expr_rect_Type3 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13799) + +(** val expr_rect_Type2 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 + -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 + -> 'a1) -> AST.typ -> expr -> 'a1 **) +let rec expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost x_13808 = function +| Id (t, x_13810) -> h_Id t x_13810 +| Cst (t, x_13811) -> h_Cst t x_13811 +| Op1 (t, t', x_13813, x_13812) -> + h_Op1 t t' x_13813 x_13812 + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13812) +| Op2 (t1, t2, t', x_13816, x_13815, x_13814) -> + h_Op2 t1 t2 t' x_13816 x_13815 x_13814 + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t1 x_13815) + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t2 x_13814) +| Mem (t, x_13817) -> + h_Mem t x_13817 + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost AST.ASTptr + x_13817) +| Cond (sz, sg, t, x_13820, x_13819, x_13818) -> + h_Cond sz sg t x_13820 x_13819 x_13818 + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost (AST.ASTint + (sz, sg)) x_13820) + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13819) + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13818) +| Ecost (t, x_13822, x_13821) -> + h_Ecost t x_13822 x_13821 + (expr_rect_Type2 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13821) + +(** val expr_rect_Type1 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 + -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 + -> 'a1) -> AST.typ -> expr -> 'a1 **) +let rec expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost x_13830 = function +| Id (t, x_13832) -> h_Id t x_13832 +| Cst (t, x_13833) -> h_Cst t x_13833 +| Op1 (t, t', x_13835, x_13834) -> + h_Op1 t t' x_13835 x_13834 + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13834) +| Op2 (t1, t2, t', x_13838, x_13837, x_13836) -> + h_Op2 t1 t2 t' x_13838 x_13837 x_13836 + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t1 x_13837) + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t2 x_13836) +| Mem (t, x_13839) -> + h_Mem t x_13839 + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost AST.ASTptr + x_13839) +| Cond (sz, sg, t, x_13842, x_13841, x_13840) -> + h_Cond sz sg t x_13842 x_13841 x_13840 + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost (AST.ASTint + (sz, sg)) x_13842) + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13841) + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13840) +| Ecost (t, x_13844, x_13843) -> + h_Ecost t x_13844 x_13843 + (expr_rect_Type1 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13843) + +(** val expr_rect_Type0 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 + -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 + -> 'a1) -> AST.typ -> expr -> 'a1 **) +let rec expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost x_13852 = function +| Id (t, x_13854) -> h_Id t x_13854 +| Cst (t, x_13855) -> h_Cst t x_13855 +| Op1 (t, t', x_13857, x_13856) -> + h_Op1 t t' x_13857 x_13856 + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13856) +| Op2 (t1, t2, t', x_13860, x_13859, x_13858) -> + h_Op2 t1 t2 t' x_13860 x_13859 x_13858 + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t1 x_13859) + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t2 x_13858) +| Mem (t, x_13861) -> + h_Mem t x_13861 + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost AST.ASTptr + x_13861) +| Cond (sz, sg, t, x_13864, x_13863, x_13862) -> + h_Cond sz sg t x_13864 x_13863 x_13862 + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost (AST.ASTint + (sz, sg)) x_13864) + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13863) + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13862) +| Ecost (t, x_13866, x_13865) -> + h_Ecost t x_13866 x_13865 + (expr_rect_Type0 h_Id h_Cst h_Op1 h_Op2 h_Mem h_Cond h_Ecost t x_13865) + +(** val expr_inv_rect_Type4 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ + -> FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> + __ -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type4 x1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = expr_rect_Type4 h1 h2 h3 h4 h5 h6 h7 x1 hterm in hcut __ __ + +(** val expr_inv_rect_Type3 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ + -> FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> + __ -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type3 x1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = expr_rect_Type3 h1 h2 h3 h4 h5 h6 h7 x1 hterm in hcut __ __ + +(** val expr_inv_rect_Type2 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ + -> FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> + __ -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type2 x1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = expr_rect_Type2 h1 h2 h3 h4 h5 h6 h7 x1 hterm in hcut __ __ + +(** val expr_inv_rect_Type1 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ + -> FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> + __ -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type1 x1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = expr_rect_Type1 h1 h2 h3 h4 h5 h6 h7 x1 hterm in hcut __ __ + +(** val expr_inv_rect_Type0 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ + -> FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> + __ -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type0 x1 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = expr_rect_Type0 h1 h2 h3 h4 h5 h6 h7 x1 hterm in hcut __ __ + +(** val expr_jmdiscr : AST.typ -> expr -> expr -> __ **) +let expr_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (match x with + | Id (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Cst (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Op1 (a0, a10, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Op2 (a0, a10, a2, a3, a4, a5) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __) + | Mem (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Cond (a0, a10, a2, a3, a4, a5) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __) + | Ecost (a0, a10, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +type stmt = +| St_skip +| St_assign of AST.typ * AST.ident * expr +| St_store of AST.typ * expr * expr +| St_call of (AST.ident, AST.typ) Types.prod Types.option * expr + * (AST.typ, expr) Types.dPair List.list +| St_seq of stmt * stmt +| St_ifthenelse of AST.intsize * AST.signedness * expr * stmt * stmt +| St_return of (AST.typ, expr) Types.dPair Types.option +| St_label of PreIdentifiers.identifier * stmt +| St_goto of PreIdentifiers.identifier +| St_cost of CostLabel.costlabel * stmt + +(** val stmt_rect_Type4 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr + -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> + (AST.typ, expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> + 'a1 -> 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> + 'a1 -> 'a1 -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) + -> (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 **) +let rec stmt_rect_Type4 h_St_skip h_St_assign h_St_store h_St_call h_St_seq h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost = function +| St_skip -> h_St_skip +| St_assign (t, x_14037, x_14036) -> h_St_assign t x_14037 x_14036 +| St_store (t, x_14039, x_14038) -> h_St_store t x_14039 x_14038 +| St_call (x_14042, x_14041, x_14040) -> h_St_call x_14042 x_14041 x_14040 +| St_seq (x_14044, x_14043) -> + h_St_seq x_14044 x_14043 + (stmt_rect_Type4 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14044) + (stmt_rect_Type4 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14043) +| St_ifthenelse (sz, sg, x_14047, x_14046, x_14045) -> + h_St_ifthenelse sz sg x_14047 x_14046 x_14045 + (stmt_rect_Type4 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14046) + (stmt_rect_Type4 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14045) +| St_return x_14048 -> h_St_return x_14048 +| St_label (x_14050, x_14049) -> + h_St_label x_14050 x_14049 + (stmt_rect_Type4 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14049) +| St_goto x_14051 -> h_St_goto x_14051 +| St_cost (x_14053, x_14052) -> + h_St_cost x_14053 x_14052 + (stmt_rect_Type4 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14052) + +(** val stmt_rect_Type3 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr + -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> + (AST.typ, expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> + 'a1 -> 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> + 'a1 -> 'a1 -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) + -> (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 **) +let rec stmt_rect_Type3 h_St_skip h_St_assign h_St_store h_St_call h_St_seq h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost = function +| St_skip -> h_St_skip +| St_assign (t, x_14095, x_14094) -> h_St_assign t x_14095 x_14094 +| St_store (t, x_14097, x_14096) -> h_St_store t x_14097 x_14096 +| St_call (x_14100, x_14099, x_14098) -> h_St_call x_14100 x_14099 x_14098 +| St_seq (x_14102, x_14101) -> + h_St_seq x_14102 x_14101 + (stmt_rect_Type3 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14102) + (stmt_rect_Type3 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14101) +| St_ifthenelse (sz, sg, x_14105, x_14104, x_14103) -> + h_St_ifthenelse sz sg x_14105 x_14104 x_14103 + (stmt_rect_Type3 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14104) + (stmt_rect_Type3 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14103) +| St_return x_14106 -> h_St_return x_14106 +| St_label (x_14108, x_14107) -> + h_St_label x_14108 x_14107 + (stmt_rect_Type3 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14107) +| St_goto x_14109 -> h_St_goto x_14109 +| St_cost (x_14111, x_14110) -> + h_St_cost x_14111 x_14110 + (stmt_rect_Type3 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14110) + +(** val stmt_rect_Type2 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr + -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> + (AST.typ, expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> + 'a1 -> 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> + 'a1 -> 'a1 -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) + -> (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 **) +let rec stmt_rect_Type2 h_St_skip h_St_assign h_St_store h_St_call h_St_seq h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost = function +| St_skip -> h_St_skip +| St_assign (t, x_14124, x_14123) -> h_St_assign t x_14124 x_14123 +| St_store (t, x_14126, x_14125) -> h_St_store t x_14126 x_14125 +| St_call (x_14129, x_14128, x_14127) -> h_St_call x_14129 x_14128 x_14127 +| St_seq (x_14131, x_14130) -> + h_St_seq x_14131 x_14130 + (stmt_rect_Type2 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14131) + (stmt_rect_Type2 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14130) +| St_ifthenelse (sz, sg, x_14134, x_14133, x_14132) -> + h_St_ifthenelse sz sg x_14134 x_14133 x_14132 + (stmt_rect_Type2 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14133) + (stmt_rect_Type2 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14132) +| St_return x_14135 -> h_St_return x_14135 +| St_label (x_14137, x_14136) -> + h_St_label x_14137 x_14136 + (stmt_rect_Type2 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14136) +| St_goto x_14138 -> h_St_goto x_14138 +| St_cost (x_14140, x_14139) -> + h_St_cost x_14140 x_14139 + (stmt_rect_Type2 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14139) + +(** val stmt_rect_Type1 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr + -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> + (AST.typ, expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> + 'a1 -> 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> + 'a1 -> 'a1 -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) + -> (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 **) +let rec stmt_rect_Type1 h_St_skip h_St_assign h_St_store h_St_call h_St_seq h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost = function +| St_skip -> h_St_skip +| St_assign (t, x_14153, x_14152) -> h_St_assign t x_14153 x_14152 +| St_store (t, x_14155, x_14154) -> h_St_store t x_14155 x_14154 +| St_call (x_14158, x_14157, x_14156) -> h_St_call x_14158 x_14157 x_14156 +| St_seq (x_14160, x_14159) -> + h_St_seq x_14160 x_14159 + (stmt_rect_Type1 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14160) + (stmt_rect_Type1 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14159) +| St_ifthenelse (sz, sg, x_14163, x_14162, x_14161) -> + h_St_ifthenelse sz sg x_14163 x_14162 x_14161 + (stmt_rect_Type1 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14162) + (stmt_rect_Type1 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14161) +| St_return x_14164 -> h_St_return x_14164 +| St_label (x_14166, x_14165) -> + h_St_label x_14166 x_14165 + (stmt_rect_Type1 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14165) +| St_goto x_14167 -> h_St_goto x_14167 +| St_cost (x_14169, x_14168) -> + h_St_cost x_14169 x_14168 + (stmt_rect_Type1 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14168) + +(** val stmt_rect_Type0 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr + -> 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> + (AST.typ, expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> + 'a1 -> 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> + 'a1 -> 'a1 -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) + -> (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 **) +let rec stmt_rect_Type0 h_St_skip h_St_assign h_St_store h_St_call h_St_seq h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost = function +| St_skip -> h_St_skip +| St_assign (t, x_14182, x_14181) -> h_St_assign t x_14182 x_14181 +| St_store (t, x_14184, x_14183) -> h_St_store t x_14184 x_14183 +| St_call (x_14187, x_14186, x_14185) -> h_St_call x_14187 x_14186 x_14185 +| St_seq (x_14189, x_14188) -> + h_St_seq x_14189 x_14188 + (stmt_rect_Type0 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14189) + (stmt_rect_Type0 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14188) +| St_ifthenelse (sz, sg, x_14192, x_14191, x_14190) -> + h_St_ifthenelse sz sg x_14192 x_14191 x_14190 + (stmt_rect_Type0 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14191) + (stmt_rect_Type0 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14190) +| St_return x_14193 -> h_St_return x_14193 +| St_label (x_14195, x_14194) -> + h_St_label x_14195 x_14194 + (stmt_rect_Type0 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14194) +| St_goto x_14196 -> h_St_goto x_14196 +| St_cost (x_14198, x_14197) -> + h_St_cost x_14198 x_14197 + (stmt_rect_Type0 h_St_skip h_St_assign h_St_store h_St_call h_St_seq + h_St_ifthenelse h_St_return h_St_label h_St_goto h_St_cost x_14197) + +(** val stmt_inv_rect_Type4 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) + Types.prod Types.option -> expr -> (AST.typ, expr) Types.dPair List.list + -> __ -> 'a1) -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> + 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair + Types.option -> __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ + -> 'a1) -> __ -> 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> + (CostLabel.costlabel -> stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stmt_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 = + let hcut = stmt_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 hterm in hcut __ + +(** val stmt_inv_rect_Type3 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) + Types.prod Types.option -> expr -> (AST.typ, expr) Types.dPair List.list + -> __ -> 'a1) -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> + 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair + Types.option -> __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ + -> 'a1) -> __ -> 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> + (CostLabel.costlabel -> stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stmt_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 = + let hcut = stmt_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 hterm in hcut __ + +(** val stmt_inv_rect_Type2 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) + Types.prod Types.option -> expr -> (AST.typ, expr) Types.dPair List.list + -> __ -> 'a1) -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> + 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair + Types.option -> __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ + -> 'a1) -> __ -> 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> + (CostLabel.costlabel -> stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stmt_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 = + let hcut = stmt_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 hterm in hcut __ + +(** val stmt_inv_rect_Type1 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) + Types.prod Types.option -> expr -> (AST.typ, expr) Types.dPair List.list + -> __ -> 'a1) -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> + 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair + Types.option -> __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ + -> 'a1) -> __ -> 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> + (CostLabel.costlabel -> stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stmt_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 = + let hcut = stmt_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 hterm in hcut __ + +(** val stmt_inv_rect_Type0 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) + Types.prod Types.option -> expr -> (AST.typ, expr) Types.dPair List.list + -> __ -> 'a1) -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> + 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair + Types.option -> __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ + -> 'a1) -> __ -> 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> + (CostLabel.costlabel -> stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let stmt_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 = + let hcut = stmt_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 hterm in hcut __ + +(** val stmt_discr : stmt -> stmt -> __ **) +let stmt_discr x y = + Logic.eq_rect_Type2 x + (match x with + | St_skip -> Obj.magic (fun _ dH -> dH) + | St_assign (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | St_store (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | St_call (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | St_seq (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | St_ifthenelse (a0, a1, a2, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | St_return a0 -> Obj.magic (fun _ dH -> dH __) + | St_label (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | St_goto a0 -> Obj.magic (fun _ dH -> dH __) + | St_cost (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val stmt_jmdiscr : stmt -> stmt -> __ **) +let stmt_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | St_skip -> Obj.magic (fun _ dH -> dH) + | St_assign (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | St_store (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | St_call (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | St_seq (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | St_ifthenelse (a0, a1, a2, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | St_return a0 -> Obj.magic (fun _ dH -> dH __) + | St_label (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | St_goto a0 -> Obj.magic (fun _ dH -> dH __) + | St_cost (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val labels_of : stmt -> PreIdentifiers.identifier List.list **) +let rec labels_of = function +| St_skip -> List.Nil +| St_assign (x, x0, x1) -> List.Nil +| St_store (x, x0, x1) -> List.Nil +| St_call (x, x0, x1) -> List.Nil +| St_seq (s1, s2) -> List.append (labels_of s1) (labels_of s2) +| St_ifthenelse (x, x0, x1, s1, s2) -> + List.append (labels_of s1) (labels_of s2) +| St_return x -> List.Nil +| St_label (l, s0) -> List.Cons (l, (labels_of s0)) +| St_goto x -> List.Nil +| St_cost (x, s0) -> labels_of s0 + +(** val cminor_stmt_inv_rect_Type4 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let rec cminor_stmt_inv_rect_Type4 env labels rettyp s h_mk_cminor_stmt_inv = + h_mk_cminor_stmt_inv __ __ __ + +(** val cminor_stmt_inv_rect_Type5 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let rec cminor_stmt_inv_rect_Type5 env labels rettyp s h_mk_cminor_stmt_inv = + h_mk_cminor_stmt_inv __ __ __ + +(** val cminor_stmt_inv_rect_Type3 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let rec cminor_stmt_inv_rect_Type3 env labels rettyp s h_mk_cminor_stmt_inv = + h_mk_cminor_stmt_inv __ __ __ + +(** val cminor_stmt_inv_rect_Type2 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let rec cminor_stmt_inv_rect_Type2 env labels rettyp s h_mk_cminor_stmt_inv = + h_mk_cminor_stmt_inv __ __ __ + +(** val cminor_stmt_inv_rect_Type1 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let rec cminor_stmt_inv_rect_Type1 env labels rettyp s h_mk_cminor_stmt_inv = + h_mk_cminor_stmt_inv __ __ __ + +(** val cminor_stmt_inv_rect_Type0 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let rec cminor_stmt_inv_rect_Type0 env labels rettyp s h_mk_cminor_stmt_inv = + h_mk_cminor_stmt_inv __ __ __ + +(** val cminor_stmt_inv_inv_rect_Type4 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let cminor_stmt_inv_inv_rect_Type4 x1 x2 x3 x4 h1 = + let hcut = cminor_stmt_inv_rect_Type4 x1 x2 x3 x4 h1 in hcut __ + +(** val cminor_stmt_inv_inv_rect_Type3 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let cminor_stmt_inv_inv_rect_Type3 x1 x2 x3 x4 h1 = + let hcut = cminor_stmt_inv_rect_Type3 x1 x2 x3 x4 h1 in hcut __ + +(** val cminor_stmt_inv_inv_rect_Type2 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let cminor_stmt_inv_inv_rect_Type2 x1 x2 x3 x4 h1 = + let hcut = cminor_stmt_inv_rect_Type2 x1 x2 x3 x4 h1 in hcut __ + +(** val cminor_stmt_inv_inv_rect_Type1 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let cminor_stmt_inv_inv_rect_Type1 x1 x2 x3 x4 h1 = + let hcut = cminor_stmt_inv_rect_Type1 x1 x2 x3 x4 h1 in hcut __ + +(** val cminor_stmt_inv_inv_rect_Type0 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let cminor_stmt_inv_inv_rect_Type0 x1 x2 x3 x4 h1 = + let hcut = cminor_stmt_inv_rect_Type0 x1 x2 x3 x4 h1 in hcut __ + +(** val cminor_stmt_inv_discr : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> __ **) +let cminor_stmt_inv_discr a1 a2 a3 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val cminor_stmt_inv_jmdiscr : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> __ **) +let cminor_stmt_inv_jmdiscr a1 a2 a3 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +type internal_function = { f_return : AST.typ Types.option; + f_params : (AST.ident, AST.typ) Types.prod + List.list; + f_vars : (AST.ident, AST.typ) Types.prod List.list; + f_stacksize : Nat.nat; f_body : stmt } + +(** val internal_function_rect_Type4 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ + -> 'a1) -> internal_function -> 'a1 **) +let rec internal_function_rect_Type4 h_mk_internal_function x_14493 = + let { f_return = f_return0; f_params = f_params0; f_vars = f_vars0; + f_stacksize = f_stacksize0; f_body = f_body0 } = x_14493 + in + h_mk_internal_function f_return0 f_params0 f_vars0 __ f_stacksize0 f_body0 + __ + +(** val internal_function_rect_Type5 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ + -> 'a1) -> internal_function -> 'a1 **) +let rec internal_function_rect_Type5 h_mk_internal_function x_14495 = + let { f_return = f_return0; f_params = f_params0; f_vars = f_vars0; + f_stacksize = f_stacksize0; f_body = f_body0 } = x_14495 + in + h_mk_internal_function f_return0 f_params0 f_vars0 __ f_stacksize0 f_body0 + __ + +(** val internal_function_rect_Type3 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ + -> 'a1) -> internal_function -> 'a1 **) +let rec internal_function_rect_Type3 h_mk_internal_function x_14497 = + let { f_return = f_return0; f_params = f_params0; f_vars = f_vars0; + f_stacksize = f_stacksize0; f_body = f_body0 } = x_14497 + in + h_mk_internal_function f_return0 f_params0 f_vars0 __ f_stacksize0 f_body0 + __ + +(** val internal_function_rect_Type2 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ + -> 'a1) -> internal_function -> 'a1 **) +let rec internal_function_rect_Type2 h_mk_internal_function x_14499 = + let { f_return = f_return0; f_params = f_params0; f_vars = f_vars0; + f_stacksize = f_stacksize0; f_body = f_body0 } = x_14499 + in + h_mk_internal_function f_return0 f_params0 f_vars0 __ f_stacksize0 f_body0 + __ + +(** val internal_function_rect_Type1 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ + -> 'a1) -> internal_function -> 'a1 **) +let rec internal_function_rect_Type1 h_mk_internal_function x_14501 = + let { f_return = f_return0; f_params = f_params0; f_vars = f_vars0; + f_stacksize = f_stacksize0; f_body = f_body0 } = x_14501 + in + h_mk_internal_function f_return0 f_params0 f_vars0 __ f_stacksize0 f_body0 + __ + +(** val internal_function_rect_Type0 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ + -> 'a1) -> internal_function -> 'a1 **) +let rec internal_function_rect_Type0 h_mk_internal_function x_14503 = + let { f_return = f_return0; f_params = f_params0; f_vars = f_vars0; + f_stacksize = f_stacksize0; f_body = f_body0 } = x_14503 + in + h_mk_internal_function f_return0 f_params0 f_vars0 __ f_stacksize0 f_body0 + __ + +(** val f_return : internal_function -> AST.typ Types.option **) +let rec f_return xxx = + xxx.f_return + +(** val f_params : + internal_function -> (AST.ident, AST.typ) Types.prod List.list **) +let rec f_params xxx = + xxx.f_params + +(** val f_vars : + internal_function -> (AST.ident, AST.typ) Types.prod List.list **) +let rec f_vars xxx = + xxx.f_vars + +(** val f_stacksize : internal_function -> Nat.nat **) +let rec f_stacksize xxx = + xxx.f_stacksize + +(** val f_body : internal_function -> stmt **) +let rec f_body xxx = + xxx.f_body + +(** val internal_function_inv_rect_Type4 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ + -> Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type4 hterm h1 = + let hcut = internal_function_rect_Type4 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type3 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ + -> Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type3 hterm h1 = + let hcut = internal_function_rect_Type3 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type2 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ + -> Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type2 hterm h1 = + let hcut = internal_function_rect_Type2 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type1 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ + -> Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type1 hterm h1 = + let hcut = internal_function_rect_Type1 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type0 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ + -> Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type0 hterm h1 = + let hcut = internal_function_rect_Type0 h1 hterm in hcut __ + +(** val internal_function_jmdiscr : + internal_function -> internal_function -> __ **) +let internal_function_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { f_return = a0; f_params = a1; f_vars = a2; f_stacksize = a4; + f_body = a5 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) y + +type cminor_program = + (internal_function AST.fundef, AST.init_data List.list) AST.program + +type cminor_noinit_program = + (internal_function AST.fundef, Nat.nat) AST.program + diff --git a/extracted/cminor_syntax.mli b/extracted/cminor_syntax.mli new file mode 100644 index 0000000..3210dd0 --- /dev/null +++ b/extracted/cminor_syntax.mli @@ -0,0 +1,473 @@ +open Preamble + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +type expr = +| Id of AST.typ * AST.ident +| Cst of AST.typ * FrontEndOps.constant +| Op1 of AST.typ * AST.typ * FrontEndOps.unary_operation * expr +| Op2 of AST.typ * AST.typ * AST.typ * FrontEndOps.binary_operation * + expr * expr +| Mem of AST.typ * expr +| Cond of AST.intsize * AST.signedness * AST.typ * expr * expr * expr +| Ecost of AST.typ * CostLabel.costlabel * expr + +val expr_rect_Type4 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 -> + 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 -> + 'a1) -> AST.typ -> expr -> 'a1 + +val expr_rect_Type3 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 -> + 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 -> + 'a1) -> AST.typ -> expr -> 'a1 + +val expr_rect_Type2 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 -> + 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 -> + 'a1) -> AST.typ -> expr -> 'a1 + +val expr_rect_Type1 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 -> + 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 -> + 'a1) -> AST.typ -> expr -> 'a1 + +val expr_rect_Type0 : + (AST.typ -> AST.ident -> 'a1) -> (AST.typ -> FrontEndOps.constant -> 'a1) + -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> expr -> 'a1 -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> 'a1 -> 'a1 -> 'a1) -> (AST.typ -> expr -> 'a1 -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> 'a1 -> + 'a1 -> 'a1 -> 'a1) -> (AST.typ -> CostLabel.costlabel -> expr -> 'a1 -> + 'a1) -> AST.typ -> expr -> 'a1 + +val expr_inv_rect_Type4 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ -> + FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) + -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ -> + __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> 'a1 + +val expr_inv_rect_Type3 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ -> + FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) + -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ -> + __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> 'a1 + +val expr_inv_rect_Type2 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ -> + FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) + -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ -> + __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> 'a1 + +val expr_inv_rect_Type1 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ -> + FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) + -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ -> + __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> 'a1 + +val expr_inv_rect_Type0 : + AST.typ -> expr -> (AST.typ -> AST.ident -> __ -> __ -> 'a1) -> (AST.typ -> + FrontEndOps.constant -> __ -> __ -> 'a1) -> (AST.typ -> AST.typ -> + FrontEndOps.unary_operation -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + expr -> expr -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) + -> (AST.typ -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.typ -> expr -> expr -> expr -> (__ -> + __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> __ -> __ -> 'a1) -> + (AST.typ -> CostLabel.costlabel -> expr -> (__ -> __ -> 'a1) -> __ -> __ -> + 'a1) -> 'a1 + +val expr_jmdiscr : AST.typ -> expr -> expr -> __ + +type stmt = +| St_skip +| St_assign of AST.typ * AST.ident * expr +| St_store of AST.typ * expr * expr +| St_call of (AST.ident, AST.typ) Types.prod Types.option * expr + * (AST.typ, expr) Types.dPair List.list +| St_seq of stmt * stmt +| St_ifthenelse of AST.intsize * AST.signedness * expr * stmt * stmt +| St_return of (AST.typ, expr) Types.dPair Types.option +| St_label of PreIdentifiers.identifier * stmt +| St_goto of PreIdentifiers.identifier +| St_cost of CostLabel.costlabel * stmt + +val stmt_rect_Type4 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr -> + 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> (AST.typ, + expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> 'a1 -> 'a1) + -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> 'a1 -> 'a1 -> + 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) -> + (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 + +val stmt_rect_Type3 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr -> + 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> (AST.typ, + expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> 'a1 -> 'a1) + -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> 'a1 -> 'a1 -> + 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) -> + (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 + +val stmt_rect_Type2 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr -> + 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> (AST.typ, + expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> 'a1 -> 'a1) + -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> 'a1 -> 'a1 -> + 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) -> + (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 + +val stmt_rect_Type1 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr -> + 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> (AST.typ, + expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> 'a1 -> 'a1) + -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> 'a1 -> 'a1 -> + 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) -> + (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 + +val stmt_rect_Type0 : + 'a1 -> (AST.typ -> AST.ident -> expr -> 'a1) -> (AST.typ -> expr -> expr -> + 'a1) -> ((AST.ident, AST.typ) Types.prod Types.option -> expr -> (AST.typ, + expr) Types.dPair List.list -> 'a1) -> (stmt -> stmt -> 'a1 -> 'a1 -> 'a1) + -> (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> 'a1 -> 'a1 -> + 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> 'a1) -> + (PreIdentifiers.identifier -> stmt -> 'a1 -> 'a1) -> + (PreIdentifiers.identifier -> 'a1) -> (CostLabel.costlabel -> stmt -> 'a1 + -> 'a1) -> stmt -> 'a1 + +val stmt_inv_rect_Type4 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) Types.prod + Types.option -> expr -> (AST.typ, expr) Types.dPair List.list -> __ -> 'a1) + -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> + __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ -> 'a1) -> __ -> + 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> (CostLabel.costlabel -> + stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type3 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) Types.prod + Types.option -> expr -> (AST.typ, expr) Types.dPair List.list -> __ -> 'a1) + -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> + __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ -> 'a1) -> __ -> + 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> (CostLabel.costlabel -> + stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type2 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) Types.prod + Types.option -> expr -> (AST.typ, expr) Types.dPair List.list -> __ -> 'a1) + -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> + __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ -> 'a1) -> __ -> + 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> (CostLabel.costlabel -> + stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type1 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) Types.prod + Types.option -> expr -> (AST.typ, expr) Types.dPair List.list -> __ -> 'a1) + -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> + __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ -> 'a1) -> __ -> + 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> (CostLabel.costlabel -> + stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type0 : + stmt -> (__ -> 'a1) -> (AST.typ -> AST.ident -> expr -> __ -> 'a1) -> + (AST.typ -> expr -> expr -> __ -> 'a1) -> ((AST.ident, AST.typ) Types.prod + Types.option -> expr -> (AST.typ, expr) Types.dPair List.list -> __ -> 'a1) + -> (stmt -> stmt -> (__ -> 'a1) -> (__ -> 'a1) -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> expr -> stmt -> stmt -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a1) -> ((AST.typ, expr) Types.dPair Types.option -> + __ -> 'a1) -> (PreIdentifiers.identifier -> stmt -> (__ -> 'a1) -> __ -> + 'a1) -> (PreIdentifiers.identifier -> __ -> 'a1) -> (CostLabel.costlabel -> + stmt -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val stmt_discr : stmt -> stmt -> __ + +val stmt_jmdiscr : stmt -> stmt -> __ + +val labels_of : stmt -> PreIdentifiers.identifier List.list + +val cminor_stmt_inv_rect_Type4 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val cminor_stmt_inv_rect_Type5 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val cminor_stmt_inv_rect_Type3 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val cminor_stmt_inv_rect_Type2 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val cminor_stmt_inv_rect_Type1 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val cminor_stmt_inv_rect_Type0 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val cminor_stmt_inv_inv_rect_Type4 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val cminor_stmt_inv_inv_rect_Type3 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val cminor_stmt_inv_inv_rect_Type2 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val cminor_stmt_inv_inv_rect_Type1 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val cminor_stmt_inv_inv_rect_Type0 : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> (__ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val cminor_stmt_inv_discr : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> __ + +val cminor_stmt_inv_jmdiscr : + (AST.ident, AST.typ) Types.prod List.list -> PreIdentifiers.identifier + List.list -> AST.typ Types.option -> stmt -> __ + +type internal_function = { f_return : AST.typ Types.option; + f_params : (AST.ident, AST.typ) Types.prod + List.list; + f_vars : (AST.ident, AST.typ) Types.prod List.list; + f_stacksize : Nat.nat; f_body : stmt } + +val internal_function_rect_Type4 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ -> + 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type5 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ -> + 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type3 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ -> + 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type2 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ -> + 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type1 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ -> + 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type0 : + (AST.typ Types.option -> (AST.ident, AST.typ) Types.prod List.list -> + (AST.ident, AST.typ) Types.prod List.list -> __ -> Nat.nat -> stmt -> __ -> + 'a1) -> internal_function -> 'a1 + +val f_return : internal_function -> AST.typ Types.option + +val f_params : internal_function -> (AST.ident, AST.typ) Types.prod List.list + +val f_vars : internal_function -> (AST.ident, AST.typ) Types.prod List.list + +val f_stacksize : internal_function -> Nat.nat + +val f_body : internal_function -> stmt + +val internal_function_inv_rect_Type4 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ -> + Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 + +val internal_function_inv_rect_Type3 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ -> + Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 + +val internal_function_inv_rect_Type2 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ -> + Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 + +val internal_function_inv_rect_Type1 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ -> + Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 + +val internal_function_inv_rect_Type0 : + internal_function -> (AST.typ Types.option -> (AST.ident, AST.typ) + Types.prod List.list -> (AST.ident, AST.typ) Types.prod List.list -> __ -> + Nat.nat -> stmt -> __ -> __ -> 'a1) -> 'a1 + +val internal_function_jmdiscr : internal_function -> internal_function -> __ + +type cminor_program = + (internal_function AST.fundef, AST.init_data List.list) AST.program + +type cminor_noinit_program = + (internal_function AST.fundef, Nat.nat) AST.program + diff --git a/extracted/compiler.ml b/extracted/compiler.ml new file mode 100644 index 0000000..f2c456d --- /dev/null +++ b/extracted/compiler.ml @@ -0,0 +1,756 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open Label + +open Sets + +open Listb + +open Star + +open Frontend_misc + +open CexecInd + +open Casts + +open ClassifyOp + +open Smallstep + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open Events + +open IOMonad + +open IO + +open Cexec + +open TypeComparison + +open SimplifyCasts + +open MemProperties + +open MemoryInjections + +open Fresh + +open SwitchRemoval + +open FrontEndOps + +open Cminor_syntax + +open ToCminor + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open RTLabs_syntax + +open ToRTLabs + +open Deqsets_extra + +open CostMisc + +open Listb_extra + +open CostSpec + +open CostCheck + +open CostInj + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open String + +open LabelledObjects + +open I8051 + +open BackEndOps + +open Joint + +open RTL + +open RTLabsToRTL + +open ERTL + +open RegisterSet + +open RTLToERTL + +open Fixpoints + +open Set_adt + +open Liveness + +open Interference + +open Joint_LTL_LIN + +open LTL + +open ERTLToLTL + +open LIN + +open Linearise + +open LTLToLIN + +open ASM + +open BitVectorTrieSet + +open LINToASM + +type pass = +| Clight_pass +| Clight_switch_removed_pass +| Clight_label_pass +| Clight_simplified_pass +| Cminor_pass +| Rtlabs_pass +| Rtl_separate_pass +| Rtl_uniq_pass +| Ertl_pass +| Ltl_pass +| Lin_pass +| Assembly_pass +| Object_code_pass + +(** val pass_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 **) +let rec pass_rect_Type4 h_clight_pass h_clight_switch_removed_pass h_clight_label_pass h_clight_simplified_pass h_cminor_pass h_rtlabs_pass h_rtl_separate_pass h_rtl_uniq_pass h_ertl_pass h_ltl_pass h_lin_pass h_assembly_pass h_object_code_pass = function +| Clight_pass -> h_clight_pass +| Clight_switch_removed_pass -> h_clight_switch_removed_pass +| Clight_label_pass -> h_clight_label_pass +| Clight_simplified_pass -> h_clight_simplified_pass +| Cminor_pass -> h_cminor_pass +| Rtlabs_pass -> h_rtlabs_pass +| Rtl_separate_pass -> h_rtl_separate_pass +| Rtl_uniq_pass -> h_rtl_uniq_pass +| Ertl_pass -> h_ertl_pass +| Ltl_pass -> h_ltl_pass +| Lin_pass -> h_lin_pass +| Assembly_pass -> h_assembly_pass +| Object_code_pass -> h_object_code_pass + +(** val pass_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 **) +let rec pass_rect_Type5 h_clight_pass h_clight_switch_removed_pass h_clight_label_pass h_clight_simplified_pass h_cminor_pass h_rtlabs_pass h_rtl_separate_pass h_rtl_uniq_pass h_ertl_pass h_ltl_pass h_lin_pass h_assembly_pass h_object_code_pass = function +| Clight_pass -> h_clight_pass +| Clight_switch_removed_pass -> h_clight_switch_removed_pass +| Clight_label_pass -> h_clight_label_pass +| Clight_simplified_pass -> h_clight_simplified_pass +| Cminor_pass -> h_cminor_pass +| Rtlabs_pass -> h_rtlabs_pass +| Rtl_separate_pass -> h_rtl_separate_pass +| Rtl_uniq_pass -> h_rtl_uniq_pass +| Ertl_pass -> h_ertl_pass +| Ltl_pass -> h_ltl_pass +| Lin_pass -> h_lin_pass +| Assembly_pass -> h_assembly_pass +| Object_code_pass -> h_object_code_pass + +(** val pass_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 **) +let rec pass_rect_Type3 h_clight_pass h_clight_switch_removed_pass h_clight_label_pass h_clight_simplified_pass h_cminor_pass h_rtlabs_pass h_rtl_separate_pass h_rtl_uniq_pass h_ertl_pass h_ltl_pass h_lin_pass h_assembly_pass h_object_code_pass = function +| Clight_pass -> h_clight_pass +| Clight_switch_removed_pass -> h_clight_switch_removed_pass +| Clight_label_pass -> h_clight_label_pass +| Clight_simplified_pass -> h_clight_simplified_pass +| Cminor_pass -> h_cminor_pass +| Rtlabs_pass -> h_rtlabs_pass +| Rtl_separate_pass -> h_rtl_separate_pass +| Rtl_uniq_pass -> h_rtl_uniq_pass +| Ertl_pass -> h_ertl_pass +| Ltl_pass -> h_ltl_pass +| Lin_pass -> h_lin_pass +| Assembly_pass -> h_assembly_pass +| Object_code_pass -> h_object_code_pass + +(** val pass_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 **) +let rec pass_rect_Type2 h_clight_pass h_clight_switch_removed_pass h_clight_label_pass h_clight_simplified_pass h_cminor_pass h_rtlabs_pass h_rtl_separate_pass h_rtl_uniq_pass h_ertl_pass h_ltl_pass h_lin_pass h_assembly_pass h_object_code_pass = function +| Clight_pass -> h_clight_pass +| Clight_switch_removed_pass -> h_clight_switch_removed_pass +| Clight_label_pass -> h_clight_label_pass +| Clight_simplified_pass -> h_clight_simplified_pass +| Cminor_pass -> h_cminor_pass +| Rtlabs_pass -> h_rtlabs_pass +| Rtl_separate_pass -> h_rtl_separate_pass +| Rtl_uniq_pass -> h_rtl_uniq_pass +| Ertl_pass -> h_ertl_pass +| Ltl_pass -> h_ltl_pass +| Lin_pass -> h_lin_pass +| Assembly_pass -> h_assembly_pass +| Object_code_pass -> h_object_code_pass + +(** val pass_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 **) +let rec pass_rect_Type1 h_clight_pass h_clight_switch_removed_pass h_clight_label_pass h_clight_simplified_pass h_cminor_pass h_rtlabs_pass h_rtl_separate_pass h_rtl_uniq_pass h_ertl_pass h_ltl_pass h_lin_pass h_assembly_pass h_object_code_pass = function +| Clight_pass -> h_clight_pass +| Clight_switch_removed_pass -> h_clight_switch_removed_pass +| Clight_label_pass -> h_clight_label_pass +| Clight_simplified_pass -> h_clight_simplified_pass +| Cminor_pass -> h_cminor_pass +| Rtlabs_pass -> h_rtlabs_pass +| Rtl_separate_pass -> h_rtl_separate_pass +| Rtl_uniq_pass -> h_rtl_uniq_pass +| Ertl_pass -> h_ertl_pass +| Ltl_pass -> h_ltl_pass +| Lin_pass -> h_lin_pass +| Assembly_pass -> h_assembly_pass +| Object_code_pass -> h_object_code_pass + +(** val pass_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 **) +let rec pass_rect_Type0 h_clight_pass h_clight_switch_removed_pass h_clight_label_pass h_clight_simplified_pass h_cminor_pass h_rtlabs_pass h_rtl_separate_pass h_rtl_uniq_pass h_ertl_pass h_ltl_pass h_lin_pass h_assembly_pass h_object_code_pass = function +| Clight_pass -> h_clight_pass +| Clight_switch_removed_pass -> h_clight_switch_removed_pass +| Clight_label_pass -> h_clight_label_pass +| Clight_simplified_pass -> h_clight_simplified_pass +| Cminor_pass -> h_cminor_pass +| Rtlabs_pass -> h_rtlabs_pass +| Rtl_separate_pass -> h_rtl_separate_pass +| Rtl_uniq_pass -> h_rtl_uniq_pass +| Ertl_pass -> h_ertl_pass +| Ltl_pass -> h_ltl_pass +| Lin_pass -> h_lin_pass +| Assembly_pass -> h_assembly_pass +| Object_code_pass -> h_object_code_pass + +(** val pass_inv_rect_Type4 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let pass_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = pass_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 hterm + in + hcut __ + +(** val pass_inv_rect_Type3 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let pass_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = pass_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 hterm + in + hcut __ + +(** val pass_inv_rect_Type2 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let pass_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = pass_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 hterm + in + hcut __ + +(** val pass_inv_rect_Type1 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let pass_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = pass_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 hterm + in + hcut __ + +(** val pass_inv_rect_Type0 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let pass_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = pass_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 hterm + in + hcut __ + +(** val pass_discr : pass -> pass -> __ **) +let pass_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Clight_pass -> Obj.magic (fun _ dH -> dH) + | Clight_switch_removed_pass -> Obj.magic (fun _ dH -> dH) + | Clight_label_pass -> Obj.magic (fun _ dH -> dH) + | Clight_simplified_pass -> Obj.magic (fun _ dH -> dH) + | Cminor_pass -> Obj.magic (fun _ dH -> dH) + | Rtlabs_pass -> Obj.magic (fun _ dH -> dH) + | Rtl_separate_pass -> Obj.magic (fun _ dH -> dH) + | Rtl_uniq_pass -> Obj.magic (fun _ dH -> dH) + | Ertl_pass -> Obj.magic (fun _ dH -> dH) + | Ltl_pass -> Obj.magic (fun _ dH -> dH) + | Lin_pass -> Obj.magic (fun _ dH -> dH) + | Assembly_pass -> Obj.magic (fun _ dH -> dH) + | Object_code_pass -> Obj.magic (fun _ dH -> dH)) y + +(** val pass_jmdiscr : pass -> pass -> __ **) +let pass_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Clight_pass -> Obj.magic (fun _ dH -> dH) + | Clight_switch_removed_pass -> Obj.magic (fun _ dH -> dH) + | Clight_label_pass -> Obj.magic (fun _ dH -> dH) + | Clight_simplified_pass -> Obj.magic (fun _ dH -> dH) + | Cminor_pass -> Obj.magic (fun _ dH -> dH) + | Rtlabs_pass -> Obj.magic (fun _ dH -> dH) + | Rtl_separate_pass -> Obj.magic (fun _ dH -> dH) + | Rtl_uniq_pass -> Obj.magic (fun _ dH -> dH) + | Ertl_pass -> Obj.magic (fun _ dH -> dH) + | Ltl_pass -> Obj.magic (fun _ dH -> dH) + | Lin_pass -> Obj.magic (fun _ dH -> dH) + | Assembly_pass -> Obj.magic (fun _ dH -> dH) + | Object_code_pass -> Obj.magic (fun _ dH -> dH)) y + +type 'x with_stack_model = ('x, AST.ident -> Nat.nat Types.option) Types.prod + +type syntax_of_pass = __ + +type observe_pass = pass -> syntax_of_pass -> Types.unit0 + +(** val front_end : + observe_pass -> Csyntax.clight_program -> ((CostLabel.costlabel, + Csyntax.clight_program) Types.prod, RTLabs_syntax.rTLabs_program) + Types.prod Errors.res **) +let front_end observe p = + let i = Obj.magic observe Clight_pass p in + let p0 = SwitchRemoval.program_switch_removal p in + let i0 = Obj.magic observe Clight_switch_removed_pass p0 in + let { Types.fst = p'; Types.snd = init_cost } = Label.clight_label p0 in + let i1 = Obj.magic observe Clight_label_pass p' in + let p1 = SimplifyCasts.simplify_program p' in + let i2 = Obj.magic observe Clight_simplified_pass p1 in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ToCminor.clight_to_cminor p1)) (fun p2 -> + let i3 = observe Cminor_pass p2 in + let p3 = ToRTLabs.cminor_to_rtlabs (Obj.magic p2) in + let i4 = Obj.magic observe Rtlabs_pass p3 in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (CostCheck.check_cost_program_prf p3)) (fun _ -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (CostInj.check_program_cost_injectivity_prf p3)) + (fun _ -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + { Types.fst = init_cost; Types.snd = p' }; Types.snd = p3 })))) + +open Uses + +(** val compute_fixpoint : Fixpoints.fixpoint_computer **) +let compute_fixpoint = Compute_fixpoints.compute_fixpoint + +(** val colour_graph : Interference.coloured_graph_computer **) +let colour_graph = Compute_colouring.colour_graph + +open AssocList + +(** val lookup_stack_cost : + Joint.params -> Joint.joint_program -> PreIdentifiers.identifier -> + Nat.nat Types.option **) +let lookup_stack_cost p p0 id = + AssocList.assoc_list_lookup id + (Identifiers.eq_identifier PreIdentifiers.SymbolTag) + (Joint.stack_cost p p0) + +(** val back_end : + observe_pass -> CostLabel.costlabel -> RTLabs_syntax.rTLabs_program -> + (((ASM.pseudo_assembly_program, CostLabel.costlabel) Types.prod, + Joint.stack_cost_model) Types.prod, Nat.nat) Types.prod Errors.res **) +let back_end observe init_cost p = + let p0 = RTLabsToRTL.rtlabs_to_rtl init_cost p in + let st = lookup_stack_cost (Joint.graph_params_to_params RTL.rTL) p0 in + let i = + Obj.magic observe Rtl_separate_pass { Types.fst = p0; Types.snd = st } + in + let i0 = Obj.magic observe Rtl_uniq_pass { Types.fst = p0; Types.snd = st } + in + let p1 = RTLToERTL.rtl_to_ertl p0 in + let st0 = lookup_stack_cost (Joint.graph_params_to_params ERTL.eRTL) p1 in + let i1 = Obj.magic observe Ertl_pass { Types.fst = p1; Types.snd = st0 } in + let { Types.fst = eta2; Types.snd = max_stack } = + ERTLToLTL.ertl_to_ltl compute_fixpoint colour_graph p1 + in + let { Types.fst = p2; Types.snd = stack_cost } = eta2 in + let st1 = lookup_stack_cost (Joint.graph_params_to_params LTL.lTL) p2 in + let i2 = Obj.magic observe Ltl_pass { Types.fst = p2; Types.snd = st1 } in + let st2 = lookup_stack_cost (Joint.graph_params_to_params LTL.lTL) p2 in + let p3 = LTLToLIN.ltl_to_lin p2 in + let st3 = lookup_stack_cost (Joint.lin_params_to_params LIN.lIN) p3 in + let i3 = Obj.magic observe Lin_pass { Types.fst = p3; Types.snd = st3 } in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.AssemblyTooLarge) + (LINToASM.lin_to_asm p3))) (fun p4 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = { Types.fst = + { Types.fst = p4; Types.snd = init_cost }; Types.snd = stack_cost }; + Types.snd = max_stack })) + +open Assembly + +open Status + +open Fetch + +open PolicyFront + +open PolicyStep + +open Policy + +(** val assembler : + observe_pass -> ASM.pseudo_assembly_program -> ASM.labelled_object_code + Errors.res **) +let assembler observe p = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.Jump_expansion_failed) + (Policy.jump_expansion' p))) (fun sigma_pol -> + let sigma = fun ppc -> (Types.pi1 sigma_pol).Types.fst ppc in + let pol = fun ppc -> (Types.pi1 sigma_pol).Types.snd ppc in + let i = + Obj.magic observe Assembly_pass { Types.fst = { Types.fst = p; + Types.snd = sigma }; Types.snd = pol } + in + let p0 = Assembly.assembly p sigma pol in + let i0 = Obj.magic observe Object_code_pass (Types.pi1 p0) in + Obj.magic (Errors.OK (Types.pi1 p0)))) + +open StructuredTraces + +open AbstractStatus + +open StatusProofs + +open Interpret + +open ASMCosts + +(** val lift_out_of_sigma : + 'a2 -> ('a1 -> (__, __) Types.sum) -> ('a1 Types.sig0 -> 'a2) -> 'a1 -> + 'a2 **) +let lift_out_of_sigma dflt dec m a_sig = + match dec a_sig with + | Types.Inl _ -> m a_sig + | Types.Inr _ -> dflt + +(** val lift_cost_map_back_to_front : + ASM.labelled_object_code -> StructuredTraces.as_cost_map -> + Label.clight_cost_map **) +let lift_cost_map_back_to_front oc asm_cost_map = + lift_out_of_sigma Nat.O + (Obj.magic + (BitVectorTrie.strong_decidable_in_codomain + (Identifiers.deq_identifier PreIdentifiers.CostTag) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) + (Obj.magic oc.ASM.costlabels))) asm_cost_map + +open UtilBranch + +open ASMCostsSplit + +type compiler_output = { c_labelled_object_code : ASM.labelled_object_code; + c_stack_cost : Joint.stack_cost_model; + c_max_stack : Nat.nat; + c_init_costlabel : CostLabel.costlabel; + c_labelled_clight : Csyntax.clight_program; + c_clight_cost_map : Label.clight_cost_map } + +(** val compiler_output_rect_Type4 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 **) +let rec compiler_output_rect_Type4 h_mk_compiler_output x_185 = + let { c_labelled_object_code = c_labelled_object_code0; c_stack_cost = + c_stack_cost0; c_max_stack = c_max_stack0; c_init_costlabel = + c_init_costlabel0; c_labelled_clight = c_labelled_clight0; + c_clight_cost_map = c_clight_cost_map0 } = x_185 + in + h_mk_compiler_output c_labelled_object_code0 c_stack_cost0 c_max_stack0 + c_init_costlabel0 c_labelled_clight0 c_clight_cost_map0 + +(** val compiler_output_rect_Type5 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 **) +let rec compiler_output_rect_Type5 h_mk_compiler_output x_187 = + let { c_labelled_object_code = c_labelled_object_code0; c_stack_cost = + c_stack_cost0; c_max_stack = c_max_stack0; c_init_costlabel = + c_init_costlabel0; c_labelled_clight = c_labelled_clight0; + c_clight_cost_map = c_clight_cost_map0 } = x_187 + in + h_mk_compiler_output c_labelled_object_code0 c_stack_cost0 c_max_stack0 + c_init_costlabel0 c_labelled_clight0 c_clight_cost_map0 + +(** val compiler_output_rect_Type3 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 **) +let rec compiler_output_rect_Type3 h_mk_compiler_output x_189 = + let { c_labelled_object_code = c_labelled_object_code0; c_stack_cost = + c_stack_cost0; c_max_stack = c_max_stack0; c_init_costlabel = + c_init_costlabel0; c_labelled_clight = c_labelled_clight0; + c_clight_cost_map = c_clight_cost_map0 } = x_189 + in + h_mk_compiler_output c_labelled_object_code0 c_stack_cost0 c_max_stack0 + c_init_costlabel0 c_labelled_clight0 c_clight_cost_map0 + +(** val compiler_output_rect_Type2 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 **) +let rec compiler_output_rect_Type2 h_mk_compiler_output x_191 = + let { c_labelled_object_code = c_labelled_object_code0; c_stack_cost = + c_stack_cost0; c_max_stack = c_max_stack0; c_init_costlabel = + c_init_costlabel0; c_labelled_clight = c_labelled_clight0; + c_clight_cost_map = c_clight_cost_map0 } = x_191 + in + h_mk_compiler_output c_labelled_object_code0 c_stack_cost0 c_max_stack0 + c_init_costlabel0 c_labelled_clight0 c_clight_cost_map0 + +(** val compiler_output_rect_Type1 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 **) +let rec compiler_output_rect_Type1 h_mk_compiler_output x_193 = + let { c_labelled_object_code = c_labelled_object_code0; c_stack_cost = + c_stack_cost0; c_max_stack = c_max_stack0; c_init_costlabel = + c_init_costlabel0; c_labelled_clight = c_labelled_clight0; + c_clight_cost_map = c_clight_cost_map0 } = x_193 + in + h_mk_compiler_output c_labelled_object_code0 c_stack_cost0 c_max_stack0 + c_init_costlabel0 c_labelled_clight0 c_clight_cost_map0 + +(** val compiler_output_rect_Type0 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 **) +let rec compiler_output_rect_Type0 h_mk_compiler_output x_195 = + let { c_labelled_object_code = c_labelled_object_code0; c_stack_cost = + c_stack_cost0; c_max_stack = c_max_stack0; c_init_costlabel = + c_init_costlabel0; c_labelled_clight = c_labelled_clight0; + c_clight_cost_map = c_clight_cost_map0 } = x_195 + in + h_mk_compiler_output c_labelled_object_code0 c_stack_cost0 c_max_stack0 + c_init_costlabel0 c_labelled_clight0 c_clight_cost_map0 + +(** val c_labelled_object_code : + compiler_output -> ASM.labelled_object_code **) +let rec c_labelled_object_code xxx = + xxx.c_labelled_object_code + +(** val c_stack_cost : compiler_output -> Joint.stack_cost_model **) +let rec c_stack_cost xxx = + xxx.c_stack_cost + +(** val c_max_stack : compiler_output -> Nat.nat **) +let rec c_max_stack xxx = + xxx.c_max_stack + +(** val c_init_costlabel : compiler_output -> CostLabel.costlabel **) +let rec c_init_costlabel xxx = + xxx.c_init_costlabel + +(** val c_labelled_clight : compiler_output -> Csyntax.clight_program **) +let rec c_labelled_clight xxx = + xxx.c_labelled_clight + +(** val c_clight_cost_map : compiler_output -> Label.clight_cost_map **) +let rec c_clight_cost_map xxx = + xxx.c_clight_cost_map + +(** val compiler_output_inv_rect_Type4 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 **) +let compiler_output_inv_rect_Type4 hterm h1 = + let hcut = compiler_output_rect_Type4 h1 hterm in hcut __ + +(** val compiler_output_inv_rect_Type3 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 **) +let compiler_output_inv_rect_Type3 hterm h1 = + let hcut = compiler_output_rect_Type3 h1 hterm in hcut __ + +(** val compiler_output_inv_rect_Type2 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 **) +let compiler_output_inv_rect_Type2 hterm h1 = + let hcut = compiler_output_rect_Type2 h1 hterm in hcut __ + +(** val compiler_output_inv_rect_Type1 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 **) +let compiler_output_inv_rect_Type1 hterm h1 = + let hcut = compiler_output_rect_Type1 h1 hterm in hcut __ + +(** val compiler_output_inv_rect_Type0 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 **) +let compiler_output_inv_rect_Type0 hterm h1 = + let hcut = compiler_output_rect_Type0 h1 hterm in hcut __ + +(** val compiler_output_jmdiscr : + compiler_output -> compiler_output -> __ **) +let compiler_output_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { c_labelled_object_code = a0; c_stack_cost = a1; c_max_stack = a2; + c_init_costlabel = a3; c_labelled_clight = a4; c_clight_cost_map = + a5 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val compile : + observe_pass -> Csyntax.clight_program -> compiler_output Errors.res **) +let compile observe p = + Obj.magic + (Monad.m_bind3 (Monad.max_def Errors.res0) + (Obj.magic (front_end observe p)) (fun init_cost p' p0 -> + Monad.m_bind3 (Monad.max_def Errors.res0) + (Obj.magic (back_end observe init_cost p0)) + (fun p_init_costlabel stack_cost max_stack -> + let { Types.fst = p1; Types.snd = init_costlabel } = p_init_costlabel + in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (assembler observe p1)) (fun p2 -> + let k = ASMCostsSplit.aSM_cost_map p2 in + let k' = lift_cost_map_back_to_front p2 k in + Monad.m_return0 (Monad.max_def Errors.res0) + { c_labelled_object_code = p2; c_stack_cost = stack_cost; + c_max_stack = max_stack; c_init_costlabel = init_costlabel; + c_labelled_clight = p'; c_clight_cost_map = k' })))) + diff --git a/extracted/compiler.mli b/extracted/compiler.mli new file mode 100644 index 0000000..26bd574 --- /dev/null +++ b/extracted/compiler.mli @@ -0,0 +1,440 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open Label + +open Sets + +open Listb + +open Star + +open Frontend_misc + +open CexecInd + +open Casts + +open ClassifyOp + +open Smallstep + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open Events + +open IOMonad + +open IO + +open Cexec + +open TypeComparison + +open SimplifyCasts + +open MemProperties + +open MemoryInjections + +open Fresh + +open SwitchRemoval + +open FrontEndOps + +open Cminor_syntax + +open ToCminor + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open RTLabs_syntax + +open ToRTLabs + +open Deqsets_extra + +open CostMisc + +open Listb_extra + +open CostSpec + +open CostCheck + +open CostInj + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open String + +open LabelledObjects + +open I8051 + +open BackEndOps + +open Joint + +open RTL + +open RTLabsToRTL + +open ERTL + +open RegisterSet + +open RTLToERTL + +open Fixpoints + +open Set_adt + +open Liveness + +open Interference + +open Joint_LTL_LIN + +open LTL + +open ERTLToLTL + +open LIN + +open Linearise + +open LTLToLIN + +open ASM + +open BitVectorTrieSet + +open LINToASM + +type pass = +| Clight_pass +| Clight_switch_removed_pass +| Clight_label_pass +| Clight_simplified_pass +| Cminor_pass +| Rtlabs_pass +| Rtl_separate_pass +| Rtl_uniq_pass +| Ertl_pass +| Ltl_pass +| Lin_pass +| Assembly_pass +| Object_code_pass + +val pass_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 + +val pass_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 + +val pass_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 + +val pass_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 + +val pass_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 + +val pass_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> pass -> 'a1 + +val pass_inv_rect_Type4 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val pass_inv_rect_Type3 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val pass_inv_rect_Type2 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val pass_inv_rect_Type1 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val pass_inv_rect_Type0 : + pass -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val pass_discr : pass -> pass -> __ + +val pass_jmdiscr : pass -> pass -> __ + +type 'x with_stack_model = ('x, AST.ident -> Nat.nat Types.option) Types.prod + +type syntax_of_pass = __ + +type observe_pass = pass -> syntax_of_pass -> Types.unit0 + +val front_end : + observe_pass -> Csyntax.clight_program -> ((CostLabel.costlabel, + Csyntax.clight_program) Types.prod, RTLabs_syntax.rTLabs_program) + Types.prod Errors.res + +open Uses + +val compute_fixpoint : Fixpoints.fixpoint_computer + +val colour_graph : Interference.coloured_graph_computer + +open AssocList + +val lookup_stack_cost : + Joint.params -> Joint.joint_program -> PreIdentifiers.identifier -> Nat.nat + Types.option + +val back_end : + observe_pass -> CostLabel.costlabel -> RTLabs_syntax.rTLabs_program -> + (((ASM.pseudo_assembly_program, CostLabel.costlabel) Types.prod, + Joint.stack_cost_model) Types.prod, Nat.nat) Types.prod Errors.res + +open Assembly + +open Status + +open Fetch + +open PolicyFront + +open PolicyStep + +open Policy + +val assembler : + observe_pass -> ASM.pseudo_assembly_program -> ASM.labelled_object_code + Errors.res + +open StructuredTraces + +open AbstractStatus + +open StatusProofs + +open Interpret + +open ASMCosts + +val lift_out_of_sigma : + 'a2 -> ('a1 -> (__, __) Types.sum) -> ('a1 Types.sig0 -> 'a2) -> 'a1 -> 'a2 + +val lift_cost_map_back_to_front : + ASM.labelled_object_code -> StructuredTraces.as_cost_map -> + Label.clight_cost_map + +open UtilBranch + +open ASMCostsSplit + +type compiler_output = { c_labelled_object_code : ASM.labelled_object_code; + c_stack_cost : Joint.stack_cost_model; + c_max_stack : Nat.nat; + c_init_costlabel : CostLabel.costlabel; + c_labelled_clight : Csyntax.clight_program; + c_clight_cost_map : Label.clight_cost_map } + +val compiler_output_rect_Type4 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 + +val compiler_output_rect_Type5 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 + +val compiler_output_rect_Type3 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 + +val compiler_output_rect_Type2 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 + +val compiler_output_rect_Type1 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 + +val compiler_output_rect_Type0 : + (ASM.labelled_object_code -> Joint.stack_cost_model -> Nat.nat -> + CostLabel.costlabel -> Csyntax.clight_program -> Label.clight_cost_map -> + 'a1) -> compiler_output -> 'a1 + +val c_labelled_object_code : compiler_output -> ASM.labelled_object_code + +val c_stack_cost : compiler_output -> Joint.stack_cost_model + +val c_max_stack : compiler_output -> Nat.nat + +val c_init_costlabel : compiler_output -> CostLabel.costlabel + +val c_labelled_clight : compiler_output -> Csyntax.clight_program + +val c_clight_cost_map : compiler_output -> Label.clight_cost_map + +val compiler_output_inv_rect_Type4 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 + +val compiler_output_inv_rect_Type3 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 + +val compiler_output_inv_rect_Type2 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 + +val compiler_output_inv_rect_Type1 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 + +val compiler_output_inv_rect_Type0 : + compiler_output -> (ASM.labelled_object_code -> Joint.stack_cost_model -> + Nat.nat -> CostLabel.costlabel -> Csyntax.clight_program -> + Label.clight_cost_map -> __ -> 'a1) -> 'a1 + +val compiler_output_jmdiscr : compiler_output -> compiler_output -> __ + +val compile : + observe_pass -> Csyntax.clight_program -> compiler_output Errors.res + diff --git a/extracted/coqlib.ml b/extracted/coqlib.ml new file mode 100644 index 0000000..8b28b54 --- /dev/null +++ b/extracted/coqlib.ml @@ -0,0 +1,34 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +(** val align : Nat.nat -> Nat.nat -> Nat.nat **) +let align n amount = + Nat.times + (Util.division (Nat.minus (Nat.plus n amount) (Nat.S Nat.O)) amount) + amount + diff --git a/extracted/coqlib.mli b/extracted/coqlib.mli new file mode 100644 index 0000000..f064410 --- /dev/null +++ b/extracted/coqlib.mli @@ -0,0 +1,30 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +val align : Nat.nat -> Nat.nat -> Nat.nat + diff --git a/extracted/core_notation.ml b/extracted/core_notation.ml new file mode 100644 index 0000000..d140066 --- /dev/null +++ b/extracted/core_notation.ml @@ -0,0 +1,2 @@ +open Preamble + diff --git a/extracted/core_notation.mli b/extracted/core_notation.mli new file mode 100644 index 0000000..d140066 --- /dev/null +++ b/extracted/core_notation.mli @@ -0,0 +1,2 @@ +open Preamble + diff --git a/extracted/costCheck.ml b/extracted/costCheck.ml new file mode 100644 index 0000000..017a18f --- /dev/null +++ b/extracted/costCheck.ml @@ -0,0 +1,227 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open CostSpec + +open Extra_bool + +open Sets + +open Listb + +open Listb_extra + +open CostMisc + +(** val check_well_cost_fn : RTLabs_syntax.internal_function -> Bool.bool **) +let check_well_cost_fn f = + Bool.andb + (Identifiers.idmap_all PreIdentifiers.LabelTag f.RTLabs_syntax.f_graph + (fun l s _ -> + CostSpec.well_cost_labelled_statement f.RTLabs_syntax.f_graph s)) + (CostSpec.is_cost_label + (Identifiers.lookup_present PreIdentifiers.LabelTag + f.RTLabs_syntax.f_graph (Types.pi1 f.RTLabs_syntax.f_entry))) + +open Deqsets_extra + +(** val check_label_bounded : + RTLabs_syntax.statement Graphs.graph -> Graphs.label -> Graphs.label + List.list -> Identifiers.identifier_set -> Nat.nat -> + Identifiers.identifier_set Types.option **) +let rec check_label_bounded g checking checking_tail to_check term_check = + let stop_now = Types.Some to_check in + (match term_check with + | Nat.O -> (fun _ -> assert false (* absurd case *)) + | Nat.S term_check' -> + (fun _ -> + let st = Identifiers.lookup_present PreIdentifiers.LabelTag g checking + in + let succs = CostSpec.successors st in + (match succs with + | List.Nil -> (fun _ -> stop_now) + | List.Cons (h, t) -> + (match t with + | List.Nil -> + (fun _ -> + let st' = + Identifiers.lookup_present PreIdentifiers.LabelTag g h + in + (match CostSpec.is_cost_label st' with + | Bool.True -> stop_now + | Bool.False -> + (match Identifiers.try_remove PreIdentifiers.LabelTag + to_check h with + | Types.None -> + (fun _ -> + match Bool.orb + (Deqsets.eqb + (Identifiers.deq_identifier + PreIdentifiers.LabelTag) (Obj.magic h) + (Obj.magic checking)) + (Listb.memb + (Identifiers.deq_identifier + PreIdentifiers.LabelTag) (Obj.magic h) + (Obj.magic checking_tail)) with + | Bool.True -> Types.None + | Bool.False -> stop_now) + | Types.Some to_check' -> + (fun _ -> + check_label_bounded g h (List.Cons (checking, + checking_tail)) to_check'.Types.snd term_check')) __)) + | List.Cons (x, x0) -> (fun _ -> stop_now))) __)) __ + +(** val check_graph_bounded : + RTLabs_syntax.statement Graphs.graph -> Identifiers.identifier_set -> + Graphs.label -> Nat.nat -> Bool.bool **) +let rec check_graph_bounded g to_check start term_check = + (match term_check with + | Nat.O -> (fun _ -> assert false (* absurd case *)) + | Nat.S term_check' -> + (fun _ -> + (match check_label_bounded g start List.Nil to_check + (Identifiers.id_map_size PreIdentifiers.LabelTag g) with + | Types.None -> (fun _ -> Bool.False) + | Types.Some to_check' -> + (fun _ -> + (match Identifiers.choose PreIdentifiers.LabelTag to_check' with + | Types.None -> (fun _ _ _ -> Bool.True) + | Types.Some l_to_check'' -> + (fun _ _ _ -> + check_graph_bounded g l_to_check''.Types.snd + l_to_check''.Types.fst.Types.fst term_check')) __ __ __)) + __)) __ + +(** val check_sound_cost_fn : + RTLabs_syntax.internal_function -> Bool.bool **) +let check_sound_cost_fn fn = + (match Identifiers.try_remove PreIdentifiers.LabelTag + (Identifiers.id_set_of_map PreIdentifiers.LabelTag + fn.RTLabs_syntax.f_graph) (Types.pi1 fn.RTLabs_syntax.f_entry) with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some to_check -> + (fun _ _ _ -> + check_graph_bounded fn.RTLabs_syntax.f_graph to_check.Types.snd + (Types.pi1 fn.RTLabs_syntax.f_entry) + (Identifiers.id_map_size PreIdentifiers.LabelTag + fn.RTLabs_syntax.f_graph))) __ __ __ + +(** val check_cost_program : RTLabs_syntax.rTLabs_program -> Bool.bool **) +let check_cost_program p = + Lists.all (fun fn -> + match fn.Types.snd with + | AST.Internal fn0 -> + Bool.andb (check_well_cost_fn fn0) (check_sound_cost_fn fn0) + | AST.External x -> Bool.True) p.AST.prog_funct + +(** val check_cost_program_prf : + RTLabs_syntax.rTLabs_program -> __ Errors.res **) +let check_cost_program_prf p = + (match check_cost_program p with + | Bool.True -> (fun _ -> Errors.OK __) + | Bool.False -> + (fun _ -> Errors.Error (Errors.msg ErrorMessages.BadCostLabelling))) __ + diff --git a/extracted/costCheck.mli b/extracted/costCheck.mli new file mode 100644 index 0000000..0b74f77 --- /dev/null +++ b/extracted/costCheck.mli @@ -0,0 +1,137 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open CostSpec + +open Extra_bool + +open Sets + +open Listb + +open Listb_extra + +open CostMisc + +val check_well_cost_fn : RTLabs_syntax.internal_function -> Bool.bool + +open Deqsets_extra + +val check_label_bounded : + RTLabs_syntax.statement Graphs.graph -> Graphs.label -> Graphs.label + List.list -> Identifiers.identifier_set -> Nat.nat -> + Identifiers.identifier_set Types.option + +val check_graph_bounded : + RTLabs_syntax.statement Graphs.graph -> Identifiers.identifier_set -> + Graphs.label -> Nat.nat -> Bool.bool + +val check_sound_cost_fn : RTLabs_syntax.internal_function -> Bool.bool + +val check_cost_program : RTLabs_syntax.rTLabs_program -> Bool.bool + +val check_cost_program_prf : RTLabs_syntax.rTLabs_program -> __ Errors.res + diff --git a/extracted/costInj.ml b/extracted/costInj.ml new file mode 100644 index 0000000..9bfcc09 --- /dev/null +++ b/extracted/costInj.ml @@ -0,0 +1,147 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open CostSpec + +(** val reverse_label_map : + RTLabs_syntax.statement Graphs.graph -> PreIdentifiers.identifier + Identifiers.identifier_map Types.option **) +let reverse_label_map g = + Identifiers.foldi PreIdentifiers.LabelTag (fun l s m -> + match m with + | Types.None -> Types.None + | Types.Some m0 -> + (match CostSpec.cost_label_of s with + | Types.None -> Types.Some m0 + | Types.Some cl -> + (match Identifiers.lookup PreIdentifiers.CostTag m0 cl with + | Types.None -> + Types.Some (Identifiers.add PreIdentifiers.CostTag m0 cl l) + | Types.Some x -> Types.None))) g (Types.Some + (Identifiers.empty_map PreIdentifiers.CostTag)) + +(** val check_fun_inj : RTLabs_syntax.internal_function -> Bool.bool **) +let check_fun_inj f = + match reverse_label_map f.RTLabs_syntax.f_graph with + | Types.None -> Bool.False + | Types.Some x -> Bool.True + +(** val check_program_cost_injectivity : + RTLabs_syntax.rTLabs_program -> Bool.bool **) +let check_program_cost_injectivity p = + Lists.all (fun x -> + match x.Types.snd with + | AST.Internal f -> check_fun_inj f + | AST.External x0 -> Bool.True) p.AST.prog_funct + +(** val check_program_cost_injectivity_prf : + RTLabs_syntax.rTLabs_program -> __ Errors.res **) +let check_program_cost_injectivity_prf p = + (match check_program_cost_injectivity p with + | Bool.True -> (fun _ -> Errors.OK __) + | Bool.False -> + (fun _ -> Errors.Error (Errors.msg ErrorMessages.BadCostLabelling))) __ + diff --git a/extracted/costInj.mli b/extracted/costInj.mli new file mode 100644 index 0000000..c4fa249 --- /dev/null +++ b/extracted/costInj.mli @@ -0,0 +1,120 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open CostSpec + +val reverse_label_map : + RTLabs_syntax.statement Graphs.graph -> PreIdentifiers.identifier + Identifiers.identifier_map Types.option + +val check_fun_inj : RTLabs_syntax.internal_function -> Bool.bool + +val check_program_cost_injectivity : + RTLabs_syntax.rTLabs_program -> Bool.bool + +val check_program_cost_injectivity_prf : + RTLabs_syntax.rTLabs_program -> __ Errors.res + diff --git a/extracted/costLabel.ml b/extracted/costLabel.ml new file mode 100644 index 0000000..254fe58 --- /dev/null +++ b/extracted/costLabel.ml @@ -0,0 +1,64 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +type costlabel = PreIdentifiers.identifier + +(** val costlabel_eq : costlabel -> costlabel -> (__, __) Types.sum **) +let costlabel_eq = + Identifiers.identifier_eq PreIdentifiers.CostTag + +(** val costlabel_of_nat : Nat.nat -> costlabel **) +let costlabel_of_nat = + Identifiers.identifier_of_nat PreIdentifiers.CostTag + diff --git a/extracted/costLabel.mli b/extracted/costLabel.mli new file mode 100644 index 0000000..b730ab8 --- /dev/null +++ b/extracted/costLabel.mli @@ -0,0 +1,60 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +type costlabel = PreIdentifiers.identifier + +val costlabel_eq : costlabel -> costlabel -> (__, __) Types.sum + +val costlabel_of_nat : Nat.nat -> costlabel + diff --git a/extracted/costMisc.ml b/extracted/costMisc.ml new file mode 100644 index 0000000..f2985b9 --- /dev/null +++ b/extracted/costMisc.ml @@ -0,0 +1,112 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open CostSpec + +open Sets + +open Listb + diff --git a/extracted/costMisc.mli b/extracted/costMisc.mli new file mode 100644 index 0000000..f2985b9 --- /dev/null +++ b/extracted/costMisc.mli @@ -0,0 +1,112 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open CostSpec + +open Sets + +open Listb + diff --git a/extracted/costSpec.ml b/extracted/costSpec.ml new file mode 100644 index 0000000..b1372a2 --- /dev/null +++ b/extracted/costSpec.ml @@ -0,0 +1,175 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +(** val is_cost_label : RTLabs_syntax.statement -> Bool.bool **) +let is_cost_label = function +| RTLabs_syntax.St_skip x -> Bool.False +| RTLabs_syntax.St_cost (x, x0) -> Bool.True +| RTLabs_syntax.St_const (x, x0, x1, x2) -> Bool.False +| RTLabs_syntax.St_op1 (x, x0, x1, x2, x3, x4) -> Bool.False +| RTLabs_syntax.St_op2 (x, x0, x1, x2, x3, x4, x5, x6) -> Bool.False +| RTLabs_syntax.St_load (x, x0, x1, x2) -> Bool.False +| RTLabs_syntax.St_store (x, x0, x1, x2) -> Bool.False +| RTLabs_syntax.St_call_id (x, x0, x1, x2) -> Bool.False +| RTLabs_syntax.St_call_ptr (x, x0, x1, x2) -> Bool.False +| RTLabs_syntax.St_cond (x, x0, x1) -> Bool.False +| RTLabs_syntax.St_return -> Bool.False + +(** val cost_label_of : + RTLabs_syntax.statement -> CostLabel.costlabel Types.option **) +let cost_label_of = function +| RTLabs_syntax.St_skip x -> Types.None +| RTLabs_syntax.St_cost (s0, x) -> Types.Some s0 +| RTLabs_syntax.St_const (x, x0, x1, x2) -> Types.None +| RTLabs_syntax.St_op1 (x, x0, x1, x2, x3, x4) -> Types.None +| RTLabs_syntax.St_op2 (x, x0, x1, x2, x3, x4, x5, x6) -> Types.None +| RTLabs_syntax.St_load (x, x0, x1, x2) -> Types.None +| RTLabs_syntax.St_store (x, x0, x1, x2) -> Types.None +| RTLabs_syntax.St_call_id (x, x0, x1, x2) -> Types.None +| RTLabs_syntax.St_call_ptr (x, x0, x1, x2) -> Types.None +| RTLabs_syntax.St_cond (x, x0, x1) -> Types.None +| RTLabs_syntax.St_return -> Types.None + +(** val well_cost_labelled_statement : + RTLabs_syntax.statement Graphs.graph -> RTLabs_syntax.statement -> + Bool.bool **) +let well_cost_labelled_statement g s = + (match s with + | RTLabs_syntax.St_skip x -> (fun _ -> Bool.True) + | RTLabs_syntax.St_cost (x, x0) -> (fun _ -> Bool.True) + | RTLabs_syntax.St_const (x, x0, x1, x2) -> (fun _ -> Bool.True) + | RTLabs_syntax.St_op1 (x, x0, x1, x2, x3, x4) -> (fun _ -> Bool.True) + | RTLabs_syntax.St_op2 (x, x0, x1, x2, x3, x4, x5, x6) -> + (fun _ -> Bool.True) + | RTLabs_syntax.St_load (x, x0, x1, x2) -> (fun _ -> Bool.True) + | RTLabs_syntax.St_store (x, x0, x1, x2) -> (fun _ -> Bool.True) + | RTLabs_syntax.St_call_id (x, x0, x1, x2) -> (fun _ -> Bool.True) + | RTLabs_syntax.St_call_ptr (x, x0, x1, x2) -> (fun _ -> Bool.True) + | RTLabs_syntax.St_cond (x, l1, l2) -> + (fun _ -> + Bool.andb + (is_cost_label + (Identifiers.lookup_present PreIdentifiers.LabelTag g l1)) + (is_cost_label + (Identifiers.lookup_present PreIdentifiers.LabelTag g l2))) + | RTLabs_syntax.St_return -> (fun _ -> Bool.True)) __ + +(** val successors : RTLabs_syntax.statement -> Graphs.label List.list **) +let rec successors = function +| RTLabs_syntax.St_skip l -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_cost (x, l) -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_const (x, x0, x1, l) -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_op1 (x, x0, x1, x2, x3, l) -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_op2 (x, x0, x1, x2, x3, x4, x5, l) -> + List.Cons (l, List.Nil) +| RTLabs_syntax.St_load (x, x0, x1, l) -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_store (x, x0, x1, l) -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_call_id (x, x0, x1, l) -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_call_ptr (x, x0, x1, l) -> List.Cons (l, List.Nil) +| RTLabs_syntax.St_cond (x, l1, l2) -> + List.Cons (l1, (List.Cons (l2, List.Nil))) +| RTLabs_syntax.St_return -> List.Nil + diff --git a/extracted/costSpec.mli b/extracted/costSpec.mli new file mode 100644 index 0000000..2a5e2e4 --- /dev/null +++ b/extracted/costSpec.mli @@ -0,0 +1,117 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +val is_cost_label : RTLabs_syntax.statement -> Bool.bool + +val cost_label_of : + RTLabs_syntax.statement -> CostLabel.costlabel Types.option + +val well_cost_labelled_statement : + RTLabs_syntax.statement Graphs.graph -> RTLabs_syntax.statement -> + Bool.bool + +val successors : RTLabs_syntax.statement -> Graphs.label List.list + diff --git a/extracted/csem.ml b/extracted/csem.ml new file mode 100644 index 0000000..33eb591 --- /dev/null +++ b/extracted/csem.ml @@ -0,0 +1,1264 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open CostLabel + +open Csyntax + +open Events + +open Smallstep + +open TypeComparison + +open ClassifyOp + +(** val sem_neg : + Values.val0 -> Csyntax.type0 -> Values.val0 Types.option **) +let rec sem_neg v = function +| Csyntax.Tvoid -> Types.None +| Csyntax.Tint (sz, x) -> + (match v with + | Values.Vundef -> Types.None + | Values.Vint (sz', n) -> + (match AST.eq_intsize sz sz' with + | Bool.True -> + Types.Some (Values.Vint (sz', + (Arithmetic.two_complement_negation (AST.bitsize_of_intsize sz') n))) + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) +| Csyntax.Tpointer x -> Types.None +| Csyntax.Tarray (x, x0) -> Types.None +| Csyntax.Tfunction (x, x0) -> Types.None +| Csyntax.Tstruct (x, x0) -> Types.None +| Csyntax.Tunion (x, x0) -> Types.None +| Csyntax.Tcomp_ptr x -> Types.None + +(** val sem_notint : Values.val0 -> Values.val0 Types.option **) +let rec sem_notint = function +| Values.Vundef -> Types.None +| Values.Vint (sz, n) -> + Types.Some (Values.Vint (sz, + (BitVector.exclusive_disjunction_bv (AST.bitsize_of_intsize sz) n + (Values.mone sz)))) +| Values.Vnull -> Types.None +| Values.Vptr x -> Types.None + +(** val sem_notbool : + Values.val0 -> Csyntax.type0 -> Values.val0 Types.option **) +let rec sem_notbool v = function +| Csyntax.Tvoid -> Types.None +| Csyntax.Tint (sz, x) -> + (match v with + | Values.Vundef -> Types.None + | Values.Vint (sz', n) -> + (match AST.eq_intsize sz sz' with + | Bool.True -> + Types.Some + (Values.of_bool + (BitVector.eq_bv (AST.bitsize_of_intsize sz') n + (BitVector.zero (AST.bitsize_of_intsize sz')))) + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) +| Csyntax.Tpointer x -> + (match v with + | Values.Vundef -> Types.None + | Values.Vint (x0, x1) -> Types.None + | Values.Vnull -> Types.Some Values.vtrue + | Values.Vptr x0 -> Types.Some Values.vfalse) +| Csyntax.Tarray (x, x0) -> Types.None +| Csyntax.Tfunction (x, x0) -> Types.None +| Csyntax.Tstruct (x, x0) -> Types.None +| Csyntax.Tunion (x, x0) -> Types.None +| Csyntax.Tcomp_ptr x -> Types.None + +(** val sem_add : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> + Values.val0 Types.option **) +let rec sem_add v1 t1 v2 t2 = + match ClassifyOp.classify_add t1 t2 with + | ClassifyOp.Add_case_ii (x, x0) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (Arithmetic.addition_n (AST.bitsize_of_intsize sz2) n10 n2)))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | ClassifyOp.Add_case_pi (x, ty, x0, sg) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x1, x2) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match BitVector.eq_bv (AST.bitsize_of_intsize sz2) n2 + (BitVector.zero (AST.bitsize_of_intsize sz2)) with + | Bool.True -> Types.Some Values.Vnull + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + Types.Some (Values.Vptr + (Pointers.shift_pointer_n (AST.bitsize_of_intsize sz2) ptr1 + (Csyntax.sizeof ty) sg n2)) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None)) + | ClassifyOp.Add_case_ip (x, x0, sg, ty) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x1, x2) -> Types.None + | Values.Vnull -> + (match BitVector.eq_bv (AST.bitsize_of_intsize sz1) n1 + (BitVector.zero (AST.bitsize_of_intsize sz1)) with + | Bool.True -> Types.Some Values.Vnull + | Bool.False -> Types.None) + | Values.Vptr ptr2 -> + Types.Some (Values.Vptr + (Pointers.shift_pointer_n (AST.bitsize_of_intsize sz1) ptr2 + (Csyntax.sizeof ty) sg n1))) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | ClassifyOp.Add_default (x, x0) -> Types.None + +(** val sem_sub : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> + Csyntax.type0 -> Values.val0 Types.option **) +let rec sem_sub v1 t1 v2 t2 target = + match ClassifyOp.classify_sub t1 t2 with + | ClassifyOp.Sub_case_ii (x, x0) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (Arithmetic.subtraction (AST.bitsize_of_intsize sz2) n10 n2)))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | ClassifyOp.Sub_case_pi (x, ty, x0, sg) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x1, x2) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match BitVector.eq_bv (AST.bitsize_of_intsize sz2) n2 + (BitVector.zero (AST.bitsize_of_intsize sz2)) with + | Bool.True -> Types.Some Values.Vnull + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + Types.Some (Values.Vptr + (Pointers.neg_shift_pointer_n (AST.bitsize_of_intsize sz2) ptr1 + (Csyntax.sizeof ty) sg n2)) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None)) + | ClassifyOp.Sub_case_pp (x, x0, ty, x1) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x2, x3) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x2, x3) -> Types.None + | Values.Vnull -> + (match target with + | Csyntax.Tvoid -> Types.None + | Csyntax.Tint (tsz, tsg) -> + Types.Some (Values.Vint (tsz, + (BitVector.zero (AST.bitsize_of_intsize tsz)))) + | Csyntax.Tpointer x2 -> Types.None + | Csyntax.Tarray (x2, x3) -> Types.None + | Csyntax.Tfunction (x2, x3) -> Types.None + | Csyntax.Tstruct (x2, x3) -> Types.None + | Csyntax.Tunion (x2, x3) -> Types.None + | Csyntax.Tcomp_ptr x2 -> Types.None) + | Values.Vptr x2 -> Types.None) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x2, x3) -> Types.None + | Values.Vnull -> Types.None + | Values.Vptr ptr2 -> + (match Pointers.eq_block ptr1.Pointers.pblock ptr2.Pointers.pblock with + | Bool.True -> + (match Nat.eqb (Csyntax.sizeof ty) Nat.O with + | Bool.True -> Types.None + | Bool.False -> + (match target with + | Csyntax.Tvoid -> Types.None + | Csyntax.Tint (tsz, tsg) -> + (match Arithmetic.division_u (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))) + (Pointers.sub_offset (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))) + ptr1.Pointers.poff ptr2.Pointers.poff) + (Integers.repr (Csyntax.sizeof ty)) with + | Types.None -> Types.None + | Types.Some v -> + Types.Some (Values.Vint (tsz, + (Arithmetic.zero_ext (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))) + (AST.bitsize_of_intsize tsz) v)))) + | Csyntax.Tpointer x2 -> Types.None + | Csyntax.Tarray (x2, x3) -> Types.None + | Csyntax.Tfunction (x2, x3) -> Types.None + | Csyntax.Tstruct (x2, x3) -> Types.None + | Csyntax.Tunion (x2, x3) -> Types.None + | Csyntax.Tcomp_ptr x2 -> Types.None)) + | Bool.False -> Types.None))) + | ClassifyOp.Sub_default (x, x0) -> Types.None + +(** val sem_mul : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> + Values.val0 Types.option **) +let rec sem_mul v1 t1 v2 t2 = + match ClassifyOp.classify_aop t1 t2 with + | ClassifyOp.Aop_case_ii (x, x0) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (Arithmetic.short_multiplication (AST.bitsize_of_intsize sz2) n10 + n2)))) Types.None + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x1 -> Types.None) + | ClassifyOp.Aop_default (x, x0) -> Types.None + +(** val sem_div : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> + Values.val0 Types.option **) +let rec sem_div v1 t1 v2 t2 = + match ClassifyOp.classify_aop t1 t2 with + | ClassifyOp.Aop_case_ii (x, sg) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match sg with + | AST.Signed -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x0 -> Values.Vint (sz2, x0)) + (Arithmetic.division_s (AST.bitsize_of_intsize sz2) n10 n2)) + Types.None + | AST.Unsigned -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x0 -> Values.Vint (sz2, x0)) + (Arithmetic.division_u + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz2) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) n10 n2)) Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) + | ClassifyOp.Aop_default (x, x0) -> Types.None + +(** val sem_mod : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> + Values.val0 Types.option **) +let rec sem_mod v1 t1 v2 t2 = + match ClassifyOp.classify_aop t1 t2 with + | ClassifyOp.Aop_case_ii (sz, sg) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match sg with + | AST.Signed -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x -> Values.Vint (sz2, x)) + (Arithmetic.modulus_s (AST.bitsize_of_intsize sz2) n10 n2)) + Types.None + | AST.Unsigned -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x -> Values.Vint (sz2, x)) + (Arithmetic.modulus_u + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz2) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) n10 n2)) Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | ClassifyOp.Aop_default (x, x0) -> Types.None + +(** val sem_and : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let rec sem_and v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (BitVector.conjunction_bv (AST.bitsize_of_intsize sz2) n10 n2)))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val sem_or : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let rec sem_or v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (BitVector.inclusive_disjunction_bv (AST.bitsize_of_intsize sz2) n10 + n2)))) Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val sem_xor : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let rec sem_xor v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (BitVector.exclusive_disjunction_bv (AST.bitsize_of_intsize sz2) n10 + n2)))) Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val sem_shl : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let rec sem_shl v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match Arithmetic.lt_u (AST.bitsize_of_intsize sz2) n2 + (Arithmetic.bitvector_of_nat (AST.bitsize_of_intsize sz2) + (AST.bitsize_of_intsize sz1)) with + | Bool.True -> + Types.Some (Values.Vint (sz1, + (Vector.shift_left (AST.bitsize_of_intsize sz1) + (Arithmetic.nat_of_bitvector (AST.bitsize_of_intsize sz2) n2) + n1 Bool.False))) + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val sem_shr : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> + Values.val0 Types.option **) +let rec sem_shr v1 t1 v2 t2 = + match ClassifyOp.classify_aop t1 t2 with + | ClassifyOp.Aop_case_ii (x, sg) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match sg with + | AST.Signed -> + (match Arithmetic.lt_u (AST.bitsize_of_intsize sz2) n2 + (Arithmetic.bitvector_of_nat + (AST.bitsize_of_intsize sz2) + (AST.bitsize_of_intsize sz1)) with + | Bool.True -> + Types.Some (Values.Vint (sz1, + (Vector.shift_right + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz1) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) + (Arithmetic.nat_of_bitvector (AST.bitsize_of_intsize sz2) + n2) n1 + (Vector.head' + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz1) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) n1)))) + | Bool.False -> Types.None) + | AST.Unsigned -> + (match Arithmetic.lt_u (AST.bitsize_of_intsize sz2) n2 + (Arithmetic.bitvector_of_nat + (AST.bitsize_of_intsize sz2) + (AST.bitsize_of_intsize sz1)) with + | Bool.True -> + Types.Some (Values.Vint (sz1, + (Vector.shift_right + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz1) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) + (Arithmetic.nat_of_bitvector (AST.bitsize_of_intsize sz2) + n2) n1 Bool.False))) + | Bool.False -> Types.None)) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) + | ClassifyOp.Aop_default (x, x0) -> Types.None + +(** val sem_cmp_mismatch : + Integers.comparison -> Values.val0 Types.option **) +let rec sem_cmp_mismatch = function +| Integers.Ceq -> Types.Some Values.vfalse +| Integers.Cne -> Types.Some Values.vtrue +| Integers.Clt -> Types.None +| Integers.Cle -> Types.None +| Integers.Cgt -> Types.None +| Integers.Cge -> Types.None + +(** val sem_cmp_match : Integers.comparison -> Values.val0 Types.option **) +let rec sem_cmp_match = function +| Integers.Ceq -> Types.Some Values.vtrue +| Integers.Cne -> Types.Some Values.vfalse +| Integers.Clt -> Types.None +| Integers.Cle -> Types.None +| Integers.Cgt -> Types.None +| Integers.Cge -> Types.None + +(** val sem_cmp : + Integers.comparison -> Values.val0 -> Csyntax.type0 -> Values.val0 -> + Csyntax.type0 -> GenMem.mem -> Values.val0 Types.option **) +let rec sem_cmp c v1 t1 v2 t2 m = + match ClassifyOp.classify_cmp t1 t2 with + | ClassifyOp.Cmp_case_ii (x, sg) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match sg with + | AST.Signed -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some + (Values.of_bool + (Values.cmp_int (AST.bitsize_of_intsize sz2) c n10 n2))) + Types.None + | AST.Unsigned -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some + (Values.of_bool + (Values.cmpu_int (AST.bitsize_of_intsize sz2) c n10 n2))) + Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x0 -> Types.None) + | ClassifyOp.Cmp_case_pp (x, x0) -> + (match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x1, x2) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x1, x2) -> Types.None + | Values.Vnull -> sem_cmp_match c + | Values.Vptr ptr2 -> sem_cmp_mismatch c) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x1, x2) -> Types.None + | Values.Vnull -> sem_cmp_mismatch c + | Values.Vptr ptr2 -> + (match Bool.andb (FrontEndMem.valid_pointer m ptr1) + (FrontEndMem.valid_pointer m ptr2) with + | Bool.True -> + (match Pointers.eq_block ptr1.Pointers.pblock + ptr2.Pointers.pblock with + | Bool.True -> + Types.Some + (Values.of_bool + (Values.cmp_offset c ptr1.Pointers.poff + ptr2.Pointers.poff)) + | Bool.False -> sem_cmp_mismatch c) + | Bool.False -> Types.None))) + | ClassifyOp.Cmp_default (x, x0) -> Types.None + +(** val cast_bool_to_target : + Csyntax.type0 -> Values.val0 Types.option -> Values.val0 Types.option **) +let cast_bool_to_target ty = function +| Types.None -> Types.None +| Types.Some v -> + (match ty with + | Csyntax.Tvoid -> Types.None + | Csyntax.Tint (sz, sg) -> Types.Some (Values.zero_ext sz v) + | Csyntax.Tpointer x -> Types.None + | Csyntax.Tarray (x, x0) -> Types.None + | Csyntax.Tfunction (x, x0) -> Types.None + | Csyntax.Tstruct (x, x0) -> Types.None + | Csyntax.Tunion (x, x0) -> Types.None + | Csyntax.Tcomp_ptr x -> Types.None) + +(** val sem_unary_operation : + Csyntax.unary_operation -> Values.val0 -> Csyntax.type0 -> Values.val0 + Types.option **) +let sem_unary_operation op v ty = + match op with + | Csyntax.Onotbool -> sem_notbool v ty + | Csyntax.Onotint -> sem_notint v + | Csyntax.Oneg -> sem_neg v ty + +(** val sem_binary_operation : + Csyntax.binary_operation -> Values.val0 -> Csyntax.type0 -> Values.val0 + -> Csyntax.type0 -> GenMem.mem -> Csyntax.type0 -> Values.val0 + Types.option **) +let rec sem_binary_operation op v1 t1 v2 t2 m ty = + match op with + | Csyntax.Oadd -> sem_add v1 t1 v2 t2 + | Csyntax.Osub -> sem_sub v1 t1 v2 t2 ty + | Csyntax.Omul -> sem_mul v1 t1 v2 t2 + | Csyntax.Odiv -> sem_div v1 t1 v2 t2 + | Csyntax.Omod -> sem_mod v1 t1 v2 t2 + | Csyntax.Oand -> sem_and v1 v2 + | Csyntax.Oor -> sem_or v1 v2 + | Csyntax.Oxor -> sem_xor v1 v2 + | Csyntax.Oshl -> sem_shl v1 v2 + | Csyntax.Oshr -> sem_shr v1 t1 v2 t2 + | Csyntax.Oeq -> + cast_bool_to_target ty (sem_cmp Integers.Ceq v1 t1 v2 t2 m) + | Csyntax.One -> + cast_bool_to_target ty (sem_cmp Integers.Cne v1 t1 v2 t2 m) + | Csyntax.Olt -> + cast_bool_to_target ty (sem_cmp Integers.Clt v1 t1 v2 t2 m) + | Csyntax.Ogt -> + cast_bool_to_target ty (sem_cmp Integers.Cgt v1 t1 v2 t2 m) + | Csyntax.Ole -> + cast_bool_to_target ty (sem_cmp Integers.Cle v1 t1 v2 t2 m) + | Csyntax.Oge -> + cast_bool_to_target ty (sem_cmp Integers.Cge v1 t1 v2 t2 m) + +(** val cast_int_int : + AST.intsize -> AST.signedness -> AST.intsize -> BitVector.bitVector -> + BitVector.bitVector **) +let rec cast_int_int sz sg dstsz i = + match sg with + | AST.Signed -> + Arithmetic.sign_ext (AST.bitsize_of_intsize sz) + (AST.bitsize_of_intsize dstsz) i + | AST.Unsigned -> + Arithmetic.zero_ext (AST.bitsize_of_intsize sz) + (AST.bitsize_of_intsize dstsz) i + +type genv = Csyntax.clight_fundef Globalenvs.genv_t + +type env = Pointers.block Identifiers.identifier_map + +(** val empty_env : env **) +let empty_env = + Identifiers.empty_map PreIdentifiers.SymbolTag + +(** val load_value_of_type : + Csyntax.type0 -> GenMem.mem -> Pointers.block -> Pointers.offset -> + Values.val0 Types.option **) +let rec load_value_of_type ty m b ofs = + match Csyntax.access_mode ty with + | Csyntax.By_value chunk -> + FrontEndMem.loadv chunk m (Values.Vptr { Pointers.pblock = b; + Pointers.poff = ofs }) + | Csyntax.By_reference -> + Types.Some (Values.Vptr { Pointers.pblock = b; Pointers.poff = ofs }) + | Csyntax.By_nothing x -> Types.None + +(** val store_value_of_type : + Csyntax.type0 -> GenMem.mem -> Pointers.block -> Pointers.offset -> + Values.val0 -> GenMem.mem Types.option **) +let rec store_value_of_type ty_dest m loc ofs v = + match Csyntax.access_mode ty_dest with + | Csyntax.By_value chunk -> + FrontEndMem.storev chunk m (Values.Vptr { Pointers.pblock = loc; + Pointers.poff = ofs }) v + | Csyntax.By_reference -> Types.None + | Csyntax.By_nothing x -> Types.None + +(** val blocks_of_env : env -> Pointers.block List.list **) +let blocks_of_env e = + List.map (fun x -> x.Types.snd) + (Identifiers.elements PreIdentifiers.SymbolTag e) + +(** val select_switch : + AST.intsize -> BitVector.bitVector -> Csyntax.labeled_statements -> + Csyntax.labeled_statements Types.option **) +let rec select_switch sz n sl = match sl with +| Csyntax.LSdefault x -> Types.Some sl +| Csyntax.LScase (sz', c, s, sl') -> + AST.intsize_eq_elim sz sz' n (fun n0 -> + match BitVector.eq_bv (AST.bitsize_of_intsize sz') c n0 with + | Bool.True -> Types.Some sl + | Bool.False -> select_switch sz' n0 sl') Types.None + +(** val seq_of_labeled_statement : + Csyntax.labeled_statements -> Csyntax.statement **) +let rec seq_of_labeled_statement = function +| Csyntax.LSdefault s -> s +| Csyntax.LScase (x, c, s, sl') -> + Csyntax.Ssequence (s, (seq_of_labeled_statement sl')) + +type cont = +| Kstop +| Kseq of Csyntax.statement * cont +| Kwhile of Csyntax.expr * Csyntax.statement * cont +| Kdowhile of Csyntax.expr * Csyntax.statement * cont +| Kfor2 of Csyntax.expr * Csyntax.statement * Csyntax.statement * cont +| Kfor3 of Csyntax.expr * Csyntax.statement * Csyntax.statement * cont +| Kswitch of cont +| Kcall of ((Pointers.block, Pointers.offset) Types.prod, Csyntax.type0) + Types.prod Types.option * Csyntax.function0 * env * cont + +(** val cont_rect_Type4 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 + -> env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 **) +let rec cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 h_Kswitch h_Kcall = function +| Kstop -> h_Kstop +| Kseq (x_8739, x_8738) -> + h_Kseq x_8739 x_8738 + (cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8738) +| Kwhile (x_8742, x_8741, x_8740) -> + h_Kwhile x_8742 x_8741 x_8740 + (cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8740) +| Kdowhile (x_8745, x_8744, x_8743) -> + h_Kdowhile x_8745 x_8744 x_8743 + (cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8743) +| Kfor2 (x_8749, x_8748, x_8747, x_8746) -> + h_Kfor2 x_8749 x_8748 x_8747 x_8746 + (cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8746) +| Kfor3 (x_8753, x_8752, x_8751, x_8750) -> + h_Kfor3 x_8753 x_8752 x_8751 x_8750 + (cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8750) +| Kswitch x_8754 -> + h_Kswitch x_8754 + (cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8754) +| Kcall (x_8758, x_8757, x_8756, x_8755) -> + h_Kcall x_8758 x_8757 x_8756 x_8755 + (cont_rect_Type4 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8755) + +(** val cont_rect_Type3 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 + -> env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 **) +let rec cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 h_Kswitch h_Kcall = function +| Kstop -> h_Kstop +| Kseq (x_8799, x_8798) -> + h_Kseq x_8799 x_8798 + (cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8798) +| Kwhile (x_8802, x_8801, x_8800) -> + h_Kwhile x_8802 x_8801 x_8800 + (cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8800) +| Kdowhile (x_8805, x_8804, x_8803) -> + h_Kdowhile x_8805 x_8804 x_8803 + (cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8803) +| Kfor2 (x_8809, x_8808, x_8807, x_8806) -> + h_Kfor2 x_8809 x_8808 x_8807 x_8806 + (cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8806) +| Kfor3 (x_8813, x_8812, x_8811, x_8810) -> + h_Kfor3 x_8813 x_8812 x_8811 x_8810 + (cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8810) +| Kswitch x_8814 -> + h_Kswitch x_8814 + (cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8814) +| Kcall (x_8818, x_8817, x_8816, x_8815) -> + h_Kcall x_8818 x_8817 x_8816 x_8815 + (cont_rect_Type3 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8815) + +(** val cont_rect_Type2 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 + -> env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 **) +let rec cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 h_Kswitch h_Kcall = function +| Kstop -> h_Kstop +| Kseq (x_8829, x_8828) -> + h_Kseq x_8829 x_8828 + (cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8828) +| Kwhile (x_8832, x_8831, x_8830) -> + h_Kwhile x_8832 x_8831 x_8830 + (cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8830) +| Kdowhile (x_8835, x_8834, x_8833) -> + h_Kdowhile x_8835 x_8834 x_8833 + (cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8833) +| Kfor2 (x_8839, x_8838, x_8837, x_8836) -> + h_Kfor2 x_8839 x_8838 x_8837 x_8836 + (cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8836) +| Kfor3 (x_8843, x_8842, x_8841, x_8840) -> + h_Kfor3 x_8843 x_8842 x_8841 x_8840 + (cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8840) +| Kswitch x_8844 -> + h_Kswitch x_8844 + (cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8844) +| Kcall (x_8848, x_8847, x_8846, x_8845) -> + h_Kcall x_8848 x_8847 x_8846 x_8845 + (cont_rect_Type2 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8845) + +(** val cont_rect_Type1 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 + -> env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 **) +let rec cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 h_Kswitch h_Kcall = function +| Kstop -> h_Kstop +| Kseq (x_8859, x_8858) -> + h_Kseq x_8859 x_8858 + (cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8858) +| Kwhile (x_8862, x_8861, x_8860) -> + h_Kwhile x_8862 x_8861 x_8860 + (cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8860) +| Kdowhile (x_8865, x_8864, x_8863) -> + h_Kdowhile x_8865 x_8864 x_8863 + (cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8863) +| Kfor2 (x_8869, x_8868, x_8867, x_8866) -> + h_Kfor2 x_8869 x_8868 x_8867 x_8866 + (cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8866) +| Kfor3 (x_8873, x_8872, x_8871, x_8870) -> + h_Kfor3 x_8873 x_8872 x_8871 x_8870 + (cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8870) +| Kswitch x_8874 -> + h_Kswitch x_8874 + (cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8874) +| Kcall (x_8878, x_8877, x_8876, x_8875) -> + h_Kcall x_8878 x_8877 x_8876 x_8875 + (cont_rect_Type1 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8875) + +(** val cont_rect_Type0 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 + -> env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 **) +let rec cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 h_Kswitch h_Kcall = function +| Kstop -> h_Kstop +| Kseq (x_8889, x_8888) -> + h_Kseq x_8889 x_8888 + (cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8888) +| Kwhile (x_8892, x_8891, x_8890) -> + h_Kwhile x_8892 x_8891 x_8890 + (cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8890) +| Kdowhile (x_8895, x_8894, x_8893) -> + h_Kdowhile x_8895 x_8894 x_8893 + (cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8893) +| Kfor2 (x_8899, x_8898, x_8897, x_8896) -> + h_Kfor2 x_8899 x_8898 x_8897 x_8896 + (cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8896) +| Kfor3 (x_8903, x_8902, x_8901, x_8900) -> + h_Kfor3 x_8903 x_8902 x_8901 x_8900 + (cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8900) +| Kswitch x_8904 -> + h_Kswitch x_8904 + (cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8904) +| Kcall (x_8908, x_8907, x_8906, x_8905) -> + h_Kcall x_8908 x_8907 x_8906 x_8905 + (cont_rect_Type0 h_Kstop h_Kseq h_Kwhile h_Kdowhile h_Kfor2 h_Kfor3 + h_Kswitch h_Kcall x_8905) + +(** val cont_inv_rect_Type4 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> + __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement + -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ + -> 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = cont_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 hterm in hcut __ + +(** val cont_inv_rect_Type3 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> + __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement + -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ + -> 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = cont_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 hterm in hcut __ + +(** val cont_inv_rect_Type2 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> + __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement + -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ + -> 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = cont_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 hterm in hcut __ + +(** val cont_inv_rect_Type1 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> + __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement + -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ + -> 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = cont_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 hterm in hcut __ + +(** val cont_inv_rect_Type0 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ + -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> + __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement + -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ + -> 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> + cont -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let cont_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = cont_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 hterm in hcut __ + +(** val cont_discr : cont -> cont -> __ **) +let cont_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Kstop -> Obj.magic (fun _ dH -> dH) + | Kseq (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Kwhile (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Kdowhile (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Kfor2 (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Kfor3 (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Kswitch a0 -> Obj.magic (fun _ dH -> dH __) + | Kcall (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val cont_jmdiscr : cont -> cont -> __ **) +let cont_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Kstop -> Obj.magic (fun _ dH -> dH) + | Kseq (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Kwhile (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Kdowhile (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Kfor2 (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Kfor3 (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Kswitch a0 -> Obj.magic (fun _ dH -> dH __) + | Kcall (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val call_cont : cont -> cont **) +let rec call_cont k = match k with +| Kstop -> k +| Kseq (s, k0) -> call_cont k0 +| Kwhile (e, s, k0) -> call_cont k0 +| Kdowhile (e, s, k0) -> call_cont k0 +| Kfor2 (e2, e3, s, k0) -> call_cont k0 +| Kfor3 (e2, e3, s, k0) -> call_cont k0 +| Kswitch k0 -> call_cont k0 +| Kcall (x, x0, x1, x2) -> k + +type state = +| State of Csyntax.function0 * Csyntax.statement * cont * env * GenMem.mem +| Callstate of AST.ident * Csyntax.clight_fundef * Values.val0 List.list + * cont * GenMem.mem +| Returnstate of Values.val0 * cont * GenMem.mem +| Finalstate of Integers.int + +(** val state_rect_Type4 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) + -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type4 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, k, e, m) -> h_State f s k e m +| Callstate (id, fd, args, k, m) -> h_Callstate id fd args k m +| Returnstate (res, k, m) -> h_Returnstate res k m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type5 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) + -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type5 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, k, e, m) -> h_State f s k e m +| Callstate (id, fd, args, k, m) -> h_Callstate id fd args k m +| Returnstate (res, k, m) -> h_Returnstate res k m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type3 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) + -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type3 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, k, e, m) -> h_State f s k e m +| Callstate (id, fd, args, k, m) -> h_Callstate id fd args k m +| Returnstate (res, k, m) -> h_Returnstate res k m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type2 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) + -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type2 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, k, e, m) -> h_State f s k e m +| Callstate (id, fd, args, k, m) -> h_Callstate id fd args k m +| Returnstate (res, k, m) -> h_Returnstate res k m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type1 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) + -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type1 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, k, e, m) -> h_State f s k e m +| Callstate (id, fd, args, k, m) -> h_Callstate id fd args k m +| Returnstate (res, k, m) -> h_Returnstate res k m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type0 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) + -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type0 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, s, k, e, m) -> h_State f s k e m +| Callstate (id, fd, args, k, m) -> h_Callstate id fd args k m +| Returnstate (res, k, m) -> h_Returnstate res k m +| Finalstate r -> h_Finalstate r + +(** val state_inv_rect_Type4 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type3 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type2 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type1 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type0 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val state_discr : state -> state -> __ **) +let state_discr x y = + Logic.eq_rect_Type2 x + (match x with + | State (a0, a1, a2, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | Callstate (a0, a1, a2, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | Returnstate (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Finalstate a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val state_jmdiscr : state -> state -> __ **) +let state_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | State (a0, a1, a2, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | Callstate (a0, a1, a2, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | Returnstate (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Finalstate a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val find_label : + Csyntax.label -> Csyntax.statement -> cont -> (Csyntax.statement, cont) + Types.prod Types.option **) +let rec find_label lbl s k = + match s with + | Csyntax.Sskip -> Types.None + | Csyntax.Sassign (x, x0) -> Types.None + | Csyntax.Scall (x, x0, x1) -> Types.None + | Csyntax.Ssequence (s1, s2) -> + (match find_label lbl s1 (Kseq (s2, k)) with + | Types.None -> find_label lbl s2 k + | Types.Some sk -> Types.Some sk) + | Csyntax.Sifthenelse (a, s1, s2) -> + (match find_label lbl s1 k with + | Types.None -> find_label lbl s2 k + | Types.Some sk -> Types.Some sk) + | Csyntax.Swhile (a, s1) -> find_label lbl s1 (Kwhile (a, s1, k)) + | Csyntax.Sdowhile (a, s1) -> find_label lbl s1 (Kdowhile (a, s1, k)) + | Csyntax.Sfor (a1, a2, a3, s1) -> + (match find_label lbl a1 (Kseq ((Csyntax.Sfor (Csyntax.Sskip, a2, a3, + s1)), k)) with + | Types.None -> + (match find_label lbl s1 (Kfor2 (a2, a3, s1, k)) with + | Types.None -> find_label lbl a3 (Kfor3 (a2, a3, s1, k)) + | Types.Some sk -> Types.Some sk) + | Types.Some sk -> Types.Some sk) + | Csyntax.Sbreak -> Types.None + | Csyntax.Scontinue -> Types.None + | Csyntax.Sreturn x -> Types.None + | Csyntax.Sswitch (e, sl) -> find_label_ls lbl sl (Kswitch k) + | Csyntax.Slabel (lbl', s') -> + (match AST.ident_eq lbl lbl' with + | Types.Inl _ -> Types.Some { Types.fst = s'; Types.snd = k } + | Types.Inr _ -> find_label lbl s' k) + | Csyntax.Sgoto x -> Types.None + | Csyntax.Scost (c, s') -> find_label lbl s' k +(** val find_label_ls : + Csyntax.label -> Csyntax.labeled_statements -> cont -> + (Csyntax.statement, cont) Types.prod Types.option **) +and find_label_ls lbl sl k = + match sl with + | Csyntax.LSdefault s -> find_label lbl s k + | Csyntax.LScase (x, x0, s, sl') -> + (match find_label lbl s (Kseq ((seq_of_labeled_statement sl'), k)) with + | Types.None -> find_label_ls lbl sl' k + | Types.Some sk -> Types.Some sk) + +(** val fun_typeof : Csyntax.expr -> Csyntax.type0 **) +let fun_typeof e = + match Csyntax.typeof e with + | Csyntax.Tvoid -> Csyntax.Tvoid + | Csyntax.Tint (a, b) -> Csyntax.Tint (a, b) + | Csyntax.Tpointer ty -> ty + | Csyntax.Tarray (a, b) -> Csyntax.Tarray (a, b) + | Csyntax.Tfunction (a, b) -> Csyntax.Tfunction (a, b) + | Csyntax.Tstruct (a, b) -> Csyntax.Tstruct (a, b) + | Csyntax.Tunion (a, b) -> Csyntax.Tunion (a, b) + | Csyntax.Tcomp_ptr a -> Csyntax.Tcomp_ptr a + diff --git a/extracted/csem.mli b/extracted/csem.mli new file mode 100644 index 0000000..2afc10b --- /dev/null +++ b/extracted/csem.mli @@ -0,0 +1,401 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open CostLabel + +open Csyntax + +open Events + +open Smallstep + +open TypeComparison + +open ClassifyOp + +val sem_neg : Values.val0 -> Csyntax.type0 -> Values.val0 Types.option + +val sem_notint : Values.val0 -> Values.val0 Types.option + +val sem_notbool : Values.val0 -> Csyntax.type0 -> Values.val0 Types.option + +val sem_add : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> Values.val0 + Types.option + +val sem_sub : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> + Csyntax.type0 -> Values.val0 Types.option + +val sem_mul : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> Values.val0 + Types.option + +val sem_div : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> Values.val0 + Types.option + +val sem_mod : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> Values.val0 + Types.option + +val sem_and : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val sem_or : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val sem_xor : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val sem_shl : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val sem_shr : + Values.val0 -> Csyntax.type0 -> Values.val0 -> Csyntax.type0 -> Values.val0 + Types.option + +val sem_cmp_mismatch : Integers.comparison -> Values.val0 Types.option + +val sem_cmp_match : Integers.comparison -> Values.val0 Types.option + +val sem_cmp : + Integers.comparison -> Values.val0 -> Csyntax.type0 -> Values.val0 -> + Csyntax.type0 -> GenMem.mem -> Values.val0 Types.option + +val cast_bool_to_target : + Csyntax.type0 -> Values.val0 Types.option -> Values.val0 Types.option + +val sem_unary_operation : + Csyntax.unary_operation -> Values.val0 -> Csyntax.type0 -> Values.val0 + Types.option + +val sem_binary_operation : + Csyntax.binary_operation -> Values.val0 -> Csyntax.type0 -> Values.val0 -> + Csyntax.type0 -> GenMem.mem -> Csyntax.type0 -> Values.val0 Types.option + +val cast_int_int : + AST.intsize -> AST.signedness -> AST.intsize -> BitVector.bitVector -> + BitVector.bitVector + +type genv = Csyntax.clight_fundef Globalenvs.genv_t + +type env = Pointers.block Identifiers.identifier_map + +val empty_env : env + +val load_value_of_type : + Csyntax.type0 -> GenMem.mem -> Pointers.block -> Pointers.offset -> + Values.val0 Types.option + +val store_value_of_type : + Csyntax.type0 -> GenMem.mem -> Pointers.block -> Pointers.offset -> + Values.val0 -> GenMem.mem Types.option + +val blocks_of_env : env -> Pointers.block List.list + +val select_switch : + AST.intsize -> BitVector.bitVector -> Csyntax.labeled_statements -> + Csyntax.labeled_statements Types.option + +val seq_of_labeled_statement : + Csyntax.labeled_statements -> Csyntax.statement + +type cont = +| Kstop +| Kseq of Csyntax.statement * cont +| Kwhile of Csyntax.expr * Csyntax.statement * cont +| Kdowhile of Csyntax.expr * Csyntax.statement * cont +| Kfor2 of Csyntax.expr * Csyntax.statement * Csyntax.statement * cont +| Kfor3 of Csyntax.expr * Csyntax.statement * Csyntax.statement * cont +| Kswitch of cont +| Kcall of ((Pointers.block, Pointers.offset) Types.prod, Csyntax.type0) + Types.prod Types.option * Csyntax.function0 * env * cont + +val cont_rect_Type4 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> + env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 + +val cont_rect_Type3 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> + env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 + +val cont_rect_Type2 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> + env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 + +val cont_rect_Type1 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> + env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 + +val cont_rect_Type0 : + 'a1 -> (Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> cont -> 'a1 -> 'a1) -> (Csyntax.expr -> + Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> 'a1) -> + (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> 'a1 -> + 'a1) -> (cont -> 'a1 -> 'a1) -> (((Pointers.block, Pointers.offset) + Types.prod, Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> + env -> cont -> 'a1 -> 'a1) -> cont -> 'a1 + +val cont_inv_rect_Type4 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> + (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> + Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ -> + 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> cont + -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type3 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> + (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> + Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ -> + 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> cont + -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type2 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> + (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> + Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ -> + 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> cont + -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type1 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> + (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> + Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ -> + 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> cont + -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_inv_rect_Type0 : + cont -> (__ -> 'a1) -> (Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> + 'a1) -> (Csyntax.expr -> Csyntax.statement -> Csyntax.statement -> cont -> + (__ -> 'a1) -> __ -> 'a1) -> (Csyntax.expr -> Csyntax.statement -> + Csyntax.statement -> cont -> (__ -> 'a1) -> __ -> 'a1) -> (cont -> (__ -> + 'a1) -> __ -> 'a1) -> (((Pointers.block, Pointers.offset) Types.prod, + Csyntax.type0) Types.prod Types.option -> Csyntax.function0 -> env -> cont + -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val cont_discr : cont -> cont -> __ + +val cont_jmdiscr : cont -> cont -> __ + +val call_cont : cont -> cont + +type state = +| State of Csyntax.function0 * Csyntax.statement * cont * env * GenMem.mem +| Callstate of AST.ident * Csyntax.clight_fundef * Values.val0 List.list + * cont * GenMem.mem +| Returnstate of Values.val0 * cont * GenMem.mem +| Finalstate of Integers.int + +val state_rect_Type4 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) -> + (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type5 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) -> + (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type3 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) -> + (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type2 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) -> + (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type1 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) -> + (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type0 : + (Csyntax.function0 -> Csyntax.statement -> cont -> env -> GenMem.mem -> + 'a1) -> (AST.ident -> Csyntax.clight_fundef -> Values.val0 List.list -> + cont -> GenMem.mem -> 'a1) -> (Values.val0 -> cont -> GenMem.mem -> 'a1) -> + (Integers.int -> 'a1) -> state -> 'a1 + +val state_inv_rect_Type4 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type3 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type2 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type1 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type0 : + state -> (Csyntax.function0 -> Csyntax.statement -> cont -> env -> + GenMem.mem -> __ -> 'a1) -> (AST.ident -> Csyntax.clight_fundef -> + Values.val0 List.list -> cont -> GenMem.mem -> __ -> 'a1) -> (Values.val0 + -> cont -> GenMem.mem -> __ -> 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 + +val state_discr : state -> state -> __ + +val state_jmdiscr : state -> state -> __ + +val find_label_ls : + Csyntax.label -> Csyntax.labeled_statements -> cont -> (Csyntax.statement, + cont) Types.prod Types.option + +val find_label : + Csyntax.label -> Csyntax.statement -> cont -> (Csyntax.statement, cont) + Types.prod Types.option + +val fun_typeof : Csyntax.expr -> Csyntax.type0 + diff --git a/extracted/csyntax.ml b/extracted/csyntax.ml new file mode 100644 index 0000000..d5eba29 --- /dev/null +++ b/extracted/csyntax.ml @@ -0,0 +1,1640 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Coqlib + +open CostLabel + +type type0 = +| Tvoid +| Tint of AST.intsize * AST.signedness +| Tpointer of type0 +| Tarray of type0 * Nat.nat +| Tfunction of typelist * type0 +| Tstruct of AST.ident * fieldlist +| Tunion of AST.ident * fieldlist +| Tcomp_ptr of AST.ident +and typelist = +| Tnil +| Tcons of type0 * typelist +and fieldlist = +| Fnil +| Fcons of AST.ident * type0 * fieldlist + +(** val type_inv_rect_Type4 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> + (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let type_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = + match hterm with + | Tvoid -> h1 + | Tint (x, x0) -> h2 x x0 + | Tpointer x -> h3 x + | Tarray (x, x0) -> h4 x x0 + | Tfunction (x, x0) -> h5 x x0 + | Tstruct (x, x0) -> h6 x x0 + | Tunion (x, x0) -> h7 x x0 + | Tcomp_ptr x -> h8 x + in + hcut __ + +(** val type_inv_rect_Type3 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> + (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let type_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = + match hterm with + | Tvoid -> h1 + | Tint (x, x0) -> h2 x x0 + | Tpointer x -> h3 x + | Tarray (x, x0) -> h4 x x0 + | Tfunction (x, x0) -> h5 x x0 + | Tstruct (x, x0) -> h6 x x0 + | Tunion (x, x0) -> h7 x x0 + | Tcomp_ptr x -> h8 x + in + hcut __ + +(** val type_inv_rect_Type2 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> + (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let type_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = + match hterm with + | Tvoid -> h1 + | Tint (x, x0) -> h2 x x0 + | Tpointer x -> h3 x + | Tarray (x, x0) -> h4 x x0 + | Tfunction (x, x0) -> h5 x x0 + | Tstruct (x, x0) -> h6 x x0 + | Tunion (x, x0) -> h7 x x0 + | Tcomp_ptr x -> h8 x + in + hcut __ + +(** val type_inv_rect_Type1 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> + (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let type_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = + match hterm with + | Tvoid -> h1 + | Tint (x, x0) -> h2 x x0 + | Tpointer x -> h3 x + | Tarray (x, x0) -> h4 x x0 + | Tfunction (x, x0) -> h5 x x0 + | Tstruct (x, x0) -> h6 x x0 + | Tunion (x, x0) -> h7 x x0 + | Tcomp_ptr x -> h8 x + in + hcut __ + +(** val type_inv_rect_Type0 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> + (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let type_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 = + let hcut = + match hterm with + | Tvoid -> h1 + | Tint (x, x0) -> h2 x x0 + | Tpointer x -> h3 x + | Tarray (x, x0) -> h4 x x0 + | Tfunction (x, x0) -> h5 x x0 + | Tstruct (x, x0) -> h6 x x0 + | Tunion (x, x0) -> h7 x x0 + | Tcomp_ptr x -> h8 x + in + hcut __ + +(** val typelist_inv_rect_Type4 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 **) +let typelist_inv_rect_Type4 hterm h1 h2 = + let hcut = + match hterm with + | Tnil -> h1 + | Tcons (x, x0) -> h2 x x0 + in + hcut __ + +(** val typelist_inv_rect_Type3 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 **) +let typelist_inv_rect_Type3 hterm h1 h2 = + let hcut = + match hterm with + | Tnil -> h1 + | Tcons (x, x0) -> h2 x x0 + in + hcut __ + +(** val typelist_inv_rect_Type2 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 **) +let typelist_inv_rect_Type2 hterm h1 h2 = + let hcut = + match hterm with + | Tnil -> h1 + | Tcons (x, x0) -> h2 x x0 + in + hcut __ + +(** val typelist_inv_rect_Type1 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 **) +let typelist_inv_rect_Type1 hterm h1 h2 = + let hcut = + match hterm with + | Tnil -> h1 + | Tcons (x, x0) -> h2 x x0 + in + hcut __ + +(** val typelist_inv_rect_Type0 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 **) +let typelist_inv_rect_Type0 hterm h1 h2 = + let hcut = + match hterm with + | Tnil -> h1 + | Tcons (x, x0) -> h2 x x0 + in + hcut __ + +(** val fieldlist_inv_rect_Type4 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> + 'a1) -> 'a1 **) +let fieldlist_inv_rect_Type4 hterm h1 h2 = + let hcut = + match hterm with + | Fnil -> h1 + | Fcons (x, x0, x1) -> h2 x x0 x1 + in + hcut __ + +(** val fieldlist_inv_rect_Type3 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> + 'a1) -> 'a1 **) +let fieldlist_inv_rect_Type3 hterm h1 h2 = + let hcut = + match hterm with + | Fnil -> h1 + | Fcons (x, x0, x1) -> h2 x x0 x1 + in + hcut __ + +(** val fieldlist_inv_rect_Type2 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> + 'a1) -> 'a1 **) +let fieldlist_inv_rect_Type2 hterm h1 h2 = + let hcut = + match hterm with + | Fnil -> h1 + | Fcons (x, x0, x1) -> h2 x x0 x1 + in + hcut __ + +(** val fieldlist_inv_rect_Type1 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> + 'a1) -> 'a1 **) +let fieldlist_inv_rect_Type1 hterm h1 h2 = + let hcut = + match hterm with + | Fnil -> h1 + | Fcons (x, x0, x1) -> h2 x x0 x1 + in + hcut __ + +(** val fieldlist_inv_rect_Type0 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> + 'a1) -> 'a1 **) +let fieldlist_inv_rect_Type0 hterm h1 h2 = + let hcut = + match hterm with + | Fnil -> h1 + | Fcons (x, x0, x1) -> h2 x x0 x1 + in + hcut __ + +(** val type_discr : type0 -> type0 -> __ **) +let type_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Tvoid -> Obj.magic (fun _ dH -> dH) + | Tint (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tpointer a0 -> Obj.magic (fun _ dH -> dH __) + | Tarray (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tfunction (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tstruct (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tunion (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tcomp_ptr a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val typelist_discr : typelist -> typelist -> __ **) +let typelist_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Tnil -> Obj.magic (fun _ dH -> dH) + | Tcons (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val fieldlist_discr : fieldlist -> fieldlist -> __ **) +let fieldlist_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Fnil -> Obj.magic (fun _ dH -> dH) + | Fcons (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val type_jmdiscr : type0 -> type0 -> __ **) +let type_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Tvoid -> Obj.magic (fun _ dH -> dH) + | Tint (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tpointer a0 -> Obj.magic (fun _ dH -> dH __) + | Tarray (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tfunction (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tstruct (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tunion (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Tcomp_ptr a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val typelist_jmdiscr : typelist -> typelist -> __ **) +let typelist_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Tnil -> Obj.magic (fun _ dH -> dH) + | Tcons (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val fieldlist_jmdiscr : fieldlist -> fieldlist -> __ **) +let fieldlist_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Fnil -> Obj.magic (fun _ dH -> dH) + | Fcons (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +type unary_operation = +| Onotbool +| Onotint +| Oneg + +(** val unary_operation_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 **) +let rec unary_operation_rect_Type4 h_Onotbool h_Onotint h_Oneg = function +| Onotbool -> h_Onotbool +| Onotint -> h_Onotint +| Oneg -> h_Oneg + +(** val unary_operation_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 **) +let rec unary_operation_rect_Type5 h_Onotbool h_Onotint h_Oneg = function +| Onotbool -> h_Onotbool +| Onotint -> h_Onotint +| Oneg -> h_Oneg + +(** val unary_operation_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 **) +let rec unary_operation_rect_Type3 h_Onotbool h_Onotint h_Oneg = function +| Onotbool -> h_Onotbool +| Onotint -> h_Onotint +| Oneg -> h_Oneg + +(** val unary_operation_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 **) +let rec unary_operation_rect_Type2 h_Onotbool h_Onotint h_Oneg = function +| Onotbool -> h_Onotbool +| Onotint -> h_Onotint +| Oneg -> h_Oneg + +(** val unary_operation_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 **) +let rec unary_operation_rect_Type1 h_Onotbool h_Onotint h_Oneg = function +| Onotbool -> h_Onotbool +| Onotint -> h_Onotint +| Oneg -> h_Oneg + +(** val unary_operation_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 **) +let rec unary_operation_rect_Type0 h_Onotbool h_Onotint h_Oneg = function +| Onotbool -> h_Onotbool +| Onotint -> h_Onotint +| Oneg -> h_Oneg + +(** val unary_operation_inv_rect_Type4 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let unary_operation_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = unary_operation_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val unary_operation_inv_rect_Type3 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let unary_operation_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = unary_operation_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val unary_operation_inv_rect_Type2 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let unary_operation_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = unary_operation_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val unary_operation_inv_rect_Type1 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let unary_operation_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = unary_operation_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val unary_operation_inv_rect_Type0 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let unary_operation_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = unary_operation_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val unary_operation_discr : unary_operation -> unary_operation -> __ **) +let unary_operation_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Onotbool -> Obj.magic (fun _ dH -> dH) + | Onotint -> Obj.magic (fun _ dH -> dH) + | Oneg -> Obj.magic (fun _ dH -> dH)) y + +(** val unary_operation_jmdiscr : + unary_operation -> unary_operation -> __ **) +let unary_operation_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Onotbool -> Obj.magic (fun _ dH -> dH) + | Onotint -> Obj.magic (fun _ dH -> dH) + | Oneg -> Obj.magic (fun _ dH -> dH)) y + +type binary_operation = +| Oadd +| Osub +| Omul +| Odiv +| Omod +| Oand +| Oor +| Oxor +| Oshl +| Oshr +| Oeq +| One +| Olt +| Ogt +| Ole +| Oge + +(** val binary_operation_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type4 h_Oadd h_Osub h_Omul h_Odiv h_Omod h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oeq h_One h_Olt h_Ogt h_Ole h_Oge = function +| Oadd -> h_Oadd +| Osub -> h_Osub +| Omul -> h_Omul +| Odiv -> h_Odiv +| Omod -> h_Omod +| Oand -> h_Oand +| Oor -> h_Oor +| Oxor -> h_Oxor +| Oshl -> h_Oshl +| Oshr -> h_Oshr +| Oeq -> h_Oeq +| One -> h_One +| Olt -> h_Olt +| Ogt -> h_Ogt +| Ole -> h_Ole +| Oge -> h_Oge + +(** val binary_operation_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type5 h_Oadd h_Osub h_Omul h_Odiv h_Omod h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oeq h_One h_Olt h_Ogt h_Ole h_Oge = function +| Oadd -> h_Oadd +| Osub -> h_Osub +| Omul -> h_Omul +| Odiv -> h_Odiv +| Omod -> h_Omod +| Oand -> h_Oand +| Oor -> h_Oor +| Oxor -> h_Oxor +| Oshl -> h_Oshl +| Oshr -> h_Oshr +| Oeq -> h_Oeq +| One -> h_One +| Olt -> h_Olt +| Ogt -> h_Ogt +| Ole -> h_Ole +| Oge -> h_Oge + +(** val binary_operation_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type3 h_Oadd h_Osub h_Omul h_Odiv h_Omod h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oeq h_One h_Olt h_Ogt h_Ole h_Oge = function +| Oadd -> h_Oadd +| Osub -> h_Osub +| Omul -> h_Omul +| Odiv -> h_Odiv +| Omod -> h_Omod +| Oand -> h_Oand +| Oor -> h_Oor +| Oxor -> h_Oxor +| Oshl -> h_Oshl +| Oshr -> h_Oshr +| Oeq -> h_Oeq +| One -> h_One +| Olt -> h_Olt +| Ogt -> h_Ogt +| Ole -> h_Ole +| Oge -> h_Oge + +(** val binary_operation_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type2 h_Oadd h_Osub h_Omul h_Odiv h_Omod h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oeq h_One h_Olt h_Ogt h_Ole h_Oge = function +| Oadd -> h_Oadd +| Osub -> h_Osub +| Omul -> h_Omul +| Odiv -> h_Odiv +| Omod -> h_Omod +| Oand -> h_Oand +| Oor -> h_Oor +| Oxor -> h_Oxor +| Oshl -> h_Oshl +| Oshr -> h_Oshr +| Oeq -> h_Oeq +| One -> h_One +| Olt -> h_Olt +| Ogt -> h_Ogt +| Ole -> h_Ole +| Oge -> h_Oge + +(** val binary_operation_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type1 h_Oadd h_Osub h_Omul h_Odiv h_Omod h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oeq h_One h_Olt h_Ogt h_Ole h_Oge = function +| Oadd -> h_Oadd +| Osub -> h_Osub +| Omul -> h_Omul +| Odiv -> h_Odiv +| Omod -> h_Omod +| Oand -> h_Oand +| Oor -> h_Oor +| Oxor -> h_Oxor +| Oshl -> h_Oshl +| Oshr -> h_Oshr +| Oeq -> h_Oeq +| One -> h_One +| Olt -> h_Olt +| Ogt -> h_Ogt +| Ole -> h_Ole +| Oge -> h_Oge + +(** val binary_operation_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type0 h_Oadd h_Osub h_Omul h_Odiv h_Omod h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oeq h_One h_Olt h_Ogt h_Ole h_Oge = function +| Oadd -> h_Oadd +| Osub -> h_Osub +| Omul -> h_Omul +| Odiv -> h_Odiv +| Omod -> h_Omod +| Oand -> h_Oand +| Oor -> h_Oor +| Oxor -> h_Oxor +| Oshl -> h_Oshl +| Oshr -> h_Oshr +| Oeq -> h_Oeq +| One -> h_One +| Olt -> h_Olt +| Ogt -> h_Ogt +| Ole -> h_Ole +| Oge -> h_Oge + +(** val binary_operation_inv_rect_Type4 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 = + let hcut = + binary_operation_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 hterm + in + hcut __ + +(** val binary_operation_inv_rect_Type3 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 = + let hcut = + binary_operation_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 hterm + in + hcut __ + +(** val binary_operation_inv_rect_Type2 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 = + let hcut = + binary_operation_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 hterm + in + hcut __ + +(** val binary_operation_inv_rect_Type1 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 = + let hcut = + binary_operation_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 hterm + in + hcut __ + +(** val binary_operation_inv_rect_Type0 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 = + let hcut = + binary_operation_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 hterm + in + hcut __ + +(** val binary_operation_discr : + binary_operation -> binary_operation -> __ **) +let binary_operation_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Oadd -> Obj.magic (fun _ dH -> dH) + | Osub -> Obj.magic (fun _ dH -> dH) + | Omul -> Obj.magic (fun _ dH -> dH) + | Odiv -> Obj.magic (fun _ dH -> dH) + | Omod -> Obj.magic (fun _ dH -> dH) + | Oand -> Obj.magic (fun _ dH -> dH) + | Oor -> Obj.magic (fun _ dH -> dH) + | Oxor -> Obj.magic (fun _ dH -> dH) + | Oshl -> Obj.magic (fun _ dH -> dH) + | Oshr -> Obj.magic (fun _ dH -> dH) + | Oeq -> Obj.magic (fun _ dH -> dH) + | One -> Obj.magic (fun _ dH -> dH) + | Olt -> Obj.magic (fun _ dH -> dH) + | Ogt -> Obj.magic (fun _ dH -> dH) + | Ole -> Obj.magic (fun _ dH -> dH) + | Oge -> Obj.magic (fun _ dH -> dH)) y + +(** val binary_operation_jmdiscr : + binary_operation -> binary_operation -> __ **) +let binary_operation_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Oadd -> Obj.magic (fun _ dH -> dH) + | Osub -> Obj.magic (fun _ dH -> dH) + | Omul -> Obj.magic (fun _ dH -> dH) + | Odiv -> Obj.magic (fun _ dH -> dH) + | Omod -> Obj.magic (fun _ dH -> dH) + | Oand -> Obj.magic (fun _ dH -> dH) + | Oor -> Obj.magic (fun _ dH -> dH) + | Oxor -> Obj.magic (fun _ dH -> dH) + | Oshl -> Obj.magic (fun _ dH -> dH) + | Oshr -> Obj.magic (fun _ dH -> dH) + | Oeq -> Obj.magic (fun _ dH -> dH) + | One -> Obj.magic (fun _ dH -> dH) + | Olt -> Obj.magic (fun _ dH -> dH) + | Ogt -> Obj.magic (fun _ dH -> dH) + | Ole -> Obj.magic (fun _ dH -> dH) + | Oge -> Obj.magic (fun _ dH -> dH)) y + +type expr = +| Expr of expr_descr * type0 +and expr_descr = +| Econst_int of AST.intsize * AST.bvint +| Evar of AST.ident +| Ederef of expr +| Eaddrof of expr +| Eunop of unary_operation * expr +| Ebinop of binary_operation * expr * expr +| Ecast of type0 * expr +| Econdition of expr * expr * expr +| Eandbool of expr * expr +| Eorbool of expr * expr +| Esizeof of type0 +| Efield of expr * AST.ident +| Ecost of CostLabel.costlabel * expr + +(** val expr_inv_rect_Type4 : + expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type4 hterm h1 = + let hcut = let Expr (x, x0) = hterm in h1 x x0 in hcut __ + +(** val expr_inv_rect_Type3 : + expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type3 hterm h1 = + let hcut = let Expr (x, x0) = hterm in h1 x x0 in hcut __ + +(** val expr_inv_rect_Type2 : + expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type2 hterm h1 = + let hcut = let Expr (x, x0) = hterm in h1 x x0 in hcut __ + +(** val expr_inv_rect_Type1 : + expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type1 hterm h1 = + let hcut = let Expr (x, x0) = hterm in h1 x x0 in hcut __ + +(** val expr_inv_rect_Type0 : + expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 **) +let expr_inv_rect_Type0 hterm h1 = + let hcut = let Expr (x, x0) = hterm in h1 x x0 in hcut __ + +(** val expr_descr_inv_rect_Type4 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) + -> (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> + __ -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> + expr -> __ -> 'a1) -> 'a1 **) +let expr_descr_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + match hterm with + | Econst_int (x, x0) -> h1 x x0 + | Evar x -> h2 x + | Ederef x -> h3 x + | Eaddrof x -> h4 x + | Eunop (x, x0) -> h5 x x0 + | Ebinop (x, x0, x1) -> h6 x x0 x1 + | Ecast (x, x0) -> h7 x x0 + | Econdition (x, x0, x1) -> h8 x x0 x1 + | Eandbool (x, x0) -> h9 x x0 + | Eorbool (x, x0) -> h10 x x0 + | Esizeof x -> h11 x + | Efield (x, x0) -> h12 x x0 + | Ecost (x, x0) -> h13 x x0 + in + hcut __ + +(** val expr_descr_inv_rect_Type3 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) + -> (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> + __ -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> + expr -> __ -> 'a1) -> 'a1 **) +let expr_descr_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + match hterm with + | Econst_int (x, x0) -> h1 x x0 + | Evar x -> h2 x + | Ederef x -> h3 x + | Eaddrof x -> h4 x + | Eunop (x, x0) -> h5 x x0 + | Ebinop (x, x0, x1) -> h6 x x0 x1 + | Ecast (x, x0) -> h7 x x0 + | Econdition (x, x0, x1) -> h8 x x0 x1 + | Eandbool (x, x0) -> h9 x x0 + | Eorbool (x, x0) -> h10 x x0 + | Esizeof x -> h11 x + | Efield (x, x0) -> h12 x x0 + | Ecost (x, x0) -> h13 x x0 + in + hcut __ + +(** val expr_descr_inv_rect_Type2 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) + -> (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> + __ -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> + expr -> __ -> 'a1) -> 'a1 **) +let expr_descr_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + match hterm with + | Econst_int (x, x0) -> h1 x x0 + | Evar x -> h2 x + | Ederef x -> h3 x + | Eaddrof x -> h4 x + | Eunop (x, x0) -> h5 x x0 + | Ebinop (x, x0, x1) -> h6 x x0 x1 + | Ecast (x, x0) -> h7 x x0 + | Econdition (x, x0, x1) -> h8 x x0 x1 + | Eandbool (x, x0) -> h9 x x0 + | Eorbool (x, x0) -> h10 x x0 + | Esizeof x -> h11 x + | Efield (x, x0) -> h12 x x0 + | Ecost (x, x0) -> h13 x x0 + in + hcut __ + +(** val expr_descr_inv_rect_Type1 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) + -> (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> + __ -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> + expr -> __ -> 'a1) -> 'a1 **) +let expr_descr_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + match hterm with + | Econst_int (x, x0) -> h1 x x0 + | Evar x -> h2 x + | Ederef x -> h3 x + | Eaddrof x -> h4 x + | Eunop (x, x0) -> h5 x x0 + | Ebinop (x, x0, x1) -> h6 x x0 x1 + | Ecast (x, x0) -> h7 x x0 + | Econdition (x, x0, x1) -> h8 x x0 x1 + | Eandbool (x, x0) -> h9 x x0 + | Eorbool (x, x0) -> h10 x x0 + | Esizeof x -> h11 x + | Efield (x, x0) -> h12 x x0 + | Ecost (x, x0) -> h13 x x0 + in + hcut __ + +(** val expr_descr_inv_rect_Type0 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) + -> (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> + __ -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> + expr -> __ -> 'a1) -> 'a1 **) +let expr_descr_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + match hterm with + | Econst_int (x, x0) -> h1 x x0 + | Evar x -> h2 x + | Ederef x -> h3 x + | Eaddrof x -> h4 x + | Eunop (x, x0) -> h5 x x0 + | Ebinop (x, x0, x1) -> h6 x x0 x1 + | Ecast (x, x0) -> h7 x x0 + | Econdition (x, x0, x1) -> h8 x x0 x1 + | Eandbool (x, x0) -> h9 x x0 + | Eorbool (x, x0) -> h10 x x0 + | Esizeof x -> h11 x + | Efield (x, x0) -> h12 x x0 + | Ecost (x, x0) -> h13 x x0 + in + hcut __ + +(** val expr_discr : expr -> expr -> __ **) +let expr_discr x y = + Logic.eq_rect_Type2 x + (let Expr (a0, a1) = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val expr_descr_discr : expr_descr -> expr_descr -> __ **) +let expr_descr_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Econst_int (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Evar a0 -> Obj.magic (fun _ dH -> dH __) + | Ederef a0 -> Obj.magic (fun _ dH -> dH __) + | Eaddrof a0 -> Obj.magic (fun _ dH -> dH __) + | Eunop (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Ebinop (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Ecast (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Econdition (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Eandbool (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Eorbool (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Esizeof a0 -> Obj.magic (fun _ dH -> dH __) + | Efield (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Ecost (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val expr_jmdiscr : expr -> expr -> __ **) +let expr_jmdiscr x y = + Logic.eq_rect_Type2 x + (let Expr (a0, a1) = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val expr_descr_jmdiscr : expr_descr -> expr_descr -> __ **) +let expr_descr_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Econst_int (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Evar a0 -> Obj.magic (fun _ dH -> dH __) + | Ederef a0 -> Obj.magic (fun _ dH -> dH __) + | Eaddrof a0 -> Obj.magic (fun _ dH -> dH __) + | Eunop (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Ebinop (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Ecast (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Econdition (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Eandbool (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Eorbool (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Esizeof a0 -> Obj.magic (fun _ dH -> dH __) + | Efield (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Ecost (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val typeof : expr -> type0 **) +let typeof = function +| Expr (de, te) -> te + +type label = AST.ident + +type statement = +| Sskip +| Sassign of expr * expr +| Scall of expr Types.option * expr * expr List.list +| Ssequence of statement * statement +| Sifthenelse of expr * statement * statement +| Swhile of expr * statement +| Sdowhile of expr * statement +| Sfor of statement * expr * statement * statement +| Sbreak +| Scontinue +| Sreturn of expr Types.option +| Sswitch of expr * labeled_statements +| Slabel of label * statement +| Sgoto of label +| Scost of CostLabel.costlabel * statement +and labeled_statements = +| LSdefault of statement +| LScase of AST.intsize * AST.bvint * statement * labeled_statements + +(** val statement_inv_rect_Type4 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) + -> (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) + -> (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) + -> 'a1 **) +let statement_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 = + let hcut = + match hterm with + | Sskip -> h1 + | Sassign (x, x0) -> h2 x x0 + | Scall (x, x0, x1) -> h3 x x0 x1 + | Ssequence (x, x0) -> h4 x x0 + | Sifthenelse (x, x0, x1) -> h5 x x0 x1 + | Swhile (x, x0) -> h6 x x0 + | Sdowhile (x, x0) -> h7 x x0 + | Sfor (x, x0, x1, x2) -> h8 x x0 x1 x2 + | Sbreak -> h9 + | Scontinue -> h10 + | Sreturn x -> h11 x + | Sswitch (x, x0) -> h12 x x0 + | Slabel (x, x0) -> h13 x x0 + | Sgoto x -> h14 x + | Scost (x, x0) -> h15 x x0 + in + hcut __ + +(** val statement_inv_rect_Type3 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) + -> (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) + -> (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) + -> 'a1 **) +let statement_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 = + let hcut = + match hterm with + | Sskip -> h1 + | Sassign (x, x0) -> h2 x x0 + | Scall (x, x0, x1) -> h3 x x0 x1 + | Ssequence (x, x0) -> h4 x x0 + | Sifthenelse (x, x0, x1) -> h5 x x0 x1 + | Swhile (x, x0) -> h6 x x0 + | Sdowhile (x, x0) -> h7 x x0 + | Sfor (x, x0, x1, x2) -> h8 x x0 x1 x2 + | Sbreak -> h9 + | Scontinue -> h10 + | Sreturn x -> h11 x + | Sswitch (x, x0) -> h12 x x0 + | Slabel (x, x0) -> h13 x x0 + | Sgoto x -> h14 x + | Scost (x, x0) -> h15 x x0 + in + hcut __ + +(** val statement_inv_rect_Type2 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) + -> (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) + -> (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) + -> 'a1 **) +let statement_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 = + let hcut = + match hterm with + | Sskip -> h1 + | Sassign (x, x0) -> h2 x x0 + | Scall (x, x0, x1) -> h3 x x0 x1 + | Ssequence (x, x0) -> h4 x x0 + | Sifthenelse (x, x0, x1) -> h5 x x0 x1 + | Swhile (x, x0) -> h6 x x0 + | Sdowhile (x, x0) -> h7 x x0 + | Sfor (x, x0, x1, x2) -> h8 x x0 x1 x2 + | Sbreak -> h9 + | Scontinue -> h10 + | Sreturn x -> h11 x + | Sswitch (x, x0) -> h12 x x0 + | Slabel (x, x0) -> h13 x x0 + | Sgoto x -> h14 x + | Scost (x, x0) -> h15 x x0 + in + hcut __ + +(** val statement_inv_rect_Type1 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) + -> (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) + -> (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) + -> 'a1 **) +let statement_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 = + let hcut = + match hterm with + | Sskip -> h1 + | Sassign (x, x0) -> h2 x x0 + | Scall (x, x0, x1) -> h3 x x0 x1 + | Ssequence (x, x0) -> h4 x x0 + | Sifthenelse (x, x0, x1) -> h5 x x0 x1 + | Swhile (x, x0) -> h6 x x0 + | Sdowhile (x, x0) -> h7 x x0 + | Sfor (x, x0, x1, x2) -> h8 x x0 x1 x2 + | Sbreak -> h9 + | Scontinue -> h10 + | Sreturn x -> h11 x + | Sswitch (x, x0) -> h12 x x0 + | Slabel (x, x0) -> h13 x x0 + | Sgoto x -> h14 x + | Scost (x, x0) -> h15 x x0 + in + hcut __ + +(** val statement_inv_rect_Type0 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) + -> (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) + -> (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) + -> 'a1 **) +let statement_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 = + let hcut = + match hterm with + | Sskip -> h1 + | Sassign (x, x0) -> h2 x x0 + | Scall (x, x0, x1) -> h3 x x0 x1 + | Ssequence (x, x0) -> h4 x x0 + | Sifthenelse (x, x0, x1) -> h5 x x0 x1 + | Swhile (x, x0) -> h6 x x0 + | Sdowhile (x, x0) -> h7 x x0 + | Sfor (x, x0, x1, x2) -> h8 x x0 x1 x2 + | Sbreak -> h9 + | Scontinue -> h10 + | Sreturn x -> h11 x + | Sswitch (x, x0) -> h12 x x0 + | Slabel (x, x0) -> h13 x x0 + | Sgoto x -> h14 x + | Scost (x, x0) -> h15 x x0 + in + hcut __ + +(** val labeled_statements_inv_rect_Type4 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> + AST.bvint -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 **) +let labeled_statements_inv_rect_Type4 hterm h1 h2 = + let hcut = + match hterm with + | LSdefault x -> h1 x + | LScase (x, x0, x1, x2) -> h2 x x0 x1 x2 + in + hcut __ + +(** val labeled_statements_inv_rect_Type3 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> + AST.bvint -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 **) +let labeled_statements_inv_rect_Type3 hterm h1 h2 = + let hcut = + match hterm with + | LSdefault x -> h1 x + | LScase (x, x0, x1, x2) -> h2 x x0 x1 x2 + in + hcut __ + +(** val labeled_statements_inv_rect_Type2 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> + AST.bvint -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 **) +let labeled_statements_inv_rect_Type2 hterm h1 h2 = + let hcut = + match hterm with + | LSdefault x -> h1 x + | LScase (x, x0, x1, x2) -> h2 x x0 x1 x2 + in + hcut __ + +(** val labeled_statements_inv_rect_Type1 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> + AST.bvint -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 **) +let labeled_statements_inv_rect_Type1 hterm h1 h2 = + let hcut = + match hterm with + | LSdefault x -> h1 x + | LScase (x, x0, x1, x2) -> h2 x x0 x1 x2 + in + hcut __ + +(** val labeled_statements_inv_rect_Type0 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> + AST.bvint -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 **) +let labeled_statements_inv_rect_Type0 hterm h1 h2 = + let hcut = + match hterm with + | LSdefault x -> h1 x + | LScase (x, x0, x1, x2) -> h2 x x0 x1 x2 + in + hcut __ + +(** val statement_discr : statement -> statement -> __ **) +let statement_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Sskip -> Obj.magic (fun _ dH -> dH) + | Sassign (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Scall (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Ssequence (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sifthenelse (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Swhile (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sdowhile (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sfor (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Sbreak -> Obj.magic (fun _ dH -> dH) + | Scontinue -> Obj.magic (fun _ dH -> dH) + | Sreturn a0 -> Obj.magic (fun _ dH -> dH __) + | Sswitch (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Slabel (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sgoto a0 -> Obj.magic (fun _ dH -> dH __) + | Scost (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val labeled_statements_discr : + labeled_statements -> labeled_statements -> __ **) +let labeled_statements_discr x y = + Logic.eq_rect_Type2 x + (match x with + | LSdefault a0 -> Obj.magic (fun _ dH -> dH __) + | LScase (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val statement_jmdiscr : statement -> statement -> __ **) +let statement_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Sskip -> Obj.magic (fun _ dH -> dH) + | Sassign (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Scall (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Ssequence (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sifthenelse (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Swhile (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sdowhile (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sfor (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Sbreak -> Obj.magic (fun _ dH -> dH) + | Scontinue -> Obj.magic (fun _ dH -> dH) + | Sreturn a0 -> Obj.magic (fun _ dH -> dH __) + | Sswitch (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Slabel (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Sgoto a0 -> Obj.magic (fun _ dH -> dH __) + | Scost (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val labeled_statements_jmdiscr : + labeled_statements -> labeled_statements -> __ **) +let labeled_statements_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | LSdefault a0 -> Obj.magic (fun _ dH -> dH __) + | LScase (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) y + +type function0 = { fn_return : type0; + fn_params : (AST.ident, type0) Types.prod List.list; + fn_vars : (AST.ident, type0) Types.prod List.list; + fn_body : statement } + +(** val function_rect_Type4 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 **) +let rec function_rect_Type4 h_mk_function x_4495 = + let { fn_return = fn_return0; fn_params = fn_params0; fn_vars = fn_vars0; + fn_body = fn_body0 } = x_4495 + in + h_mk_function fn_return0 fn_params0 fn_vars0 fn_body0 + +(** val function_rect_Type5 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 **) +let rec function_rect_Type5 h_mk_function x_4497 = + let { fn_return = fn_return0; fn_params = fn_params0; fn_vars = fn_vars0; + fn_body = fn_body0 } = x_4497 + in + h_mk_function fn_return0 fn_params0 fn_vars0 fn_body0 + +(** val function_rect_Type3 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 **) +let rec function_rect_Type3 h_mk_function x_4499 = + let { fn_return = fn_return0; fn_params = fn_params0; fn_vars = fn_vars0; + fn_body = fn_body0 } = x_4499 + in + h_mk_function fn_return0 fn_params0 fn_vars0 fn_body0 + +(** val function_rect_Type2 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 **) +let rec function_rect_Type2 h_mk_function x_4501 = + let { fn_return = fn_return0; fn_params = fn_params0; fn_vars = fn_vars0; + fn_body = fn_body0 } = x_4501 + in + h_mk_function fn_return0 fn_params0 fn_vars0 fn_body0 + +(** val function_rect_Type1 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 **) +let rec function_rect_Type1 h_mk_function x_4503 = + let { fn_return = fn_return0; fn_params = fn_params0; fn_vars = fn_vars0; + fn_body = fn_body0 } = x_4503 + in + h_mk_function fn_return0 fn_params0 fn_vars0 fn_body0 + +(** val function_rect_Type0 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 **) +let rec function_rect_Type0 h_mk_function x_4505 = + let { fn_return = fn_return0; fn_params = fn_params0; fn_vars = fn_vars0; + fn_body = fn_body0 } = x_4505 + in + h_mk_function fn_return0 fn_params0 fn_vars0 fn_body0 + +(** val fn_return : function0 -> type0 **) +let rec fn_return xxx = + xxx.fn_return + +(** val fn_params : function0 -> (AST.ident, type0) Types.prod List.list **) +let rec fn_params xxx = + xxx.fn_params + +(** val fn_vars : function0 -> (AST.ident, type0) Types.prod List.list **) +let rec fn_vars xxx = + xxx.fn_vars + +(** val fn_body : function0 -> statement **) +let rec fn_body xxx = + xxx.fn_body + +(** val function_inv_rect_Type4 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 **) +let function_inv_rect_Type4 hterm h1 = + let hcut = function_rect_Type4 h1 hterm in hcut __ + +(** val function_inv_rect_Type3 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 **) +let function_inv_rect_Type3 hterm h1 = + let hcut = function_rect_Type3 h1 hterm in hcut __ + +(** val function_inv_rect_Type2 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 **) +let function_inv_rect_Type2 hterm h1 = + let hcut = function_rect_Type2 h1 hterm in hcut __ + +(** val function_inv_rect_Type1 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 **) +let function_inv_rect_Type1 hterm h1 = + let hcut = function_rect_Type1 h1 hterm in hcut __ + +(** val function_inv_rect_Type0 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 **) +let function_inv_rect_Type0 hterm h1 = + let hcut = function_rect_Type0 h1 hterm in hcut __ + +(** val function_discr : function0 -> function0 -> __ **) +let function_discr x y = + Logic.eq_rect_Type2 x + (let { fn_return = a0; fn_params = a1; fn_vars = a2; fn_body = a3 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val function_jmdiscr : function0 -> function0 -> __ **) +let function_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { fn_return = a0; fn_params = a1; fn_vars = a2; fn_body = a3 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +type clight_fundef = +| CL_Internal of function0 +| CL_External of AST.ident * typelist * type0 + +(** val clight_fundef_rect_Type4 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 **) +let rec clight_fundef_rect_Type4 h_CL_Internal h_CL_External = function +| CL_Internal x_4527 -> h_CL_Internal x_4527 +| CL_External (x_4530, x_4529, x_4528) -> h_CL_External x_4530 x_4529 x_4528 + +(** val clight_fundef_rect_Type5 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 **) +let rec clight_fundef_rect_Type5 h_CL_Internal h_CL_External = function +| CL_Internal x_4534 -> h_CL_Internal x_4534 +| CL_External (x_4537, x_4536, x_4535) -> h_CL_External x_4537 x_4536 x_4535 + +(** val clight_fundef_rect_Type3 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 **) +let rec clight_fundef_rect_Type3 h_CL_Internal h_CL_External = function +| CL_Internal x_4541 -> h_CL_Internal x_4541 +| CL_External (x_4544, x_4543, x_4542) -> h_CL_External x_4544 x_4543 x_4542 + +(** val clight_fundef_rect_Type2 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 **) +let rec clight_fundef_rect_Type2 h_CL_Internal h_CL_External = function +| CL_Internal x_4548 -> h_CL_Internal x_4548 +| CL_External (x_4551, x_4550, x_4549) -> h_CL_External x_4551 x_4550 x_4549 + +(** val clight_fundef_rect_Type1 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 **) +let rec clight_fundef_rect_Type1 h_CL_Internal h_CL_External = function +| CL_Internal x_4555 -> h_CL_Internal x_4555 +| CL_External (x_4558, x_4557, x_4556) -> h_CL_External x_4558 x_4557 x_4556 + +(** val clight_fundef_rect_Type0 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 **) +let rec clight_fundef_rect_Type0 h_CL_Internal h_CL_External = function +| CL_Internal x_4562 -> h_CL_Internal x_4562 +| CL_External (x_4565, x_4564, x_4563) -> h_CL_External x_4565 x_4564 x_4563 + +(** val clight_fundef_inv_rect_Type4 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 **) +let clight_fundef_inv_rect_Type4 hterm h1 h2 = + let hcut = clight_fundef_rect_Type4 h1 h2 hterm in hcut __ + +(** val clight_fundef_inv_rect_Type3 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 **) +let clight_fundef_inv_rect_Type3 hterm h1 h2 = + let hcut = clight_fundef_rect_Type3 h1 h2 hterm in hcut __ + +(** val clight_fundef_inv_rect_Type2 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 **) +let clight_fundef_inv_rect_Type2 hterm h1 h2 = + let hcut = clight_fundef_rect_Type2 h1 h2 hterm in hcut __ + +(** val clight_fundef_inv_rect_Type1 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 **) +let clight_fundef_inv_rect_Type1 hterm h1 h2 = + let hcut = clight_fundef_rect_Type1 h1 h2 hterm in hcut __ + +(** val clight_fundef_inv_rect_Type0 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 **) +let clight_fundef_inv_rect_Type0 hterm h1 h2 = + let hcut = clight_fundef_rect_Type0 h1 h2 hterm in hcut __ + +(** val clight_fundef_discr : clight_fundef -> clight_fundef -> __ **) +let clight_fundef_discr x y = + Logic.eq_rect_Type2 x + (match x with + | CL_Internal a0 -> Obj.magic (fun _ dH -> dH __) + | CL_External (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val clight_fundef_jmdiscr : clight_fundef -> clight_fundef -> __ **) +let clight_fundef_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | CL_Internal a0 -> Obj.magic (fun _ dH -> dH __) + | CL_External (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +type clight_program = + (clight_fundef, (AST.init_data List.list, type0) Types.prod) AST.program + +(** val type_of_params : + (AST.ident, type0) Types.prod List.list -> typelist **) +let rec type_of_params = function +| List.Nil -> Tnil +| List.Cons (h, rem) -> + let { Types.fst = id; Types.snd = ty } = h in + Tcons (ty, (type_of_params rem)) + +(** val type_of_function : function0 -> type0 **) +let type_of_function f = + Tfunction ((type_of_params f.fn_params), f.fn_return) + +(** val type_of_fundef : clight_fundef -> type0 **) +let type_of_fundef = function +| CL_Internal fd -> type_of_function fd +| CL_External (id, args, res) -> Tfunction (args, res) + +(** val alignof : type0 -> Nat.nat **) +let rec alignof = function +| Tvoid -> Nat.S Nat.O +| Tint (sz, x) -> + (match sz with + | AST.I8 -> Nat.S Nat.O + | AST.I16 -> Nat.S (Nat.S Nat.O) + | AST.I32 -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) +| Tpointer x -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O))) +| Tarray (t', n) -> alignof t' +| Tfunction (x, x0) -> Nat.S Nat.O +| Tstruct (x, fld) -> alignof_fields fld +| Tunion (x, fld) -> alignof_fields fld +| Tcomp_ptr x -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O))) +(** val alignof_fields : fieldlist -> Nat.nat **) +and alignof_fields = function +| Fnil -> Nat.S Nat.O +| Fcons (id, t, f') -> Nat.max (alignof t) (alignof_fields f') + +(** val sizeof : type0 -> Nat.nat **) +let rec sizeof t = match t with +| Tvoid -> Nat.S Nat.O +| Tint (i, x) -> + (match i with + | AST.I8 -> Nat.S Nat.O + | AST.I16 -> Nat.S (Nat.S Nat.O) + | AST.I32 -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) +| Tpointer x -> AST.size_pointer +| Tarray (t', n) -> Nat.times (sizeof t') (Nat.max (Nat.S Nat.O) n) +| Tfunction (x, x0) -> Nat.S Nat.O +| Tstruct (x, fld) -> + Coqlib.align (Nat.max (Nat.S Nat.O) (sizeof_struct fld Nat.O)) (alignof t) +| Tunion (x, fld) -> + Coqlib.align (Nat.max (Nat.S Nat.O) (sizeof_union fld)) (alignof t) +| Tcomp_ptr x -> AST.size_pointer +(** val sizeof_struct : fieldlist -> Nat.nat -> Nat.nat **) +and sizeof_struct fld pos = + match fld with + | Fnil -> pos + | Fcons (id, t, fld') -> + sizeof_struct fld' (Nat.plus (Coqlib.align pos (alignof t)) (sizeof t)) +(** val sizeof_union : fieldlist -> Nat.nat **) +and sizeof_union = function +| Fnil -> Nat.O +| Fcons (id, t, fld') -> Nat.max (sizeof t) (sizeof_union fld') + +(** val field_offset_rec : + AST.ident -> fieldlist -> Nat.nat -> Nat.nat Errors.res **) +let rec field_offset_rec id fld pos = + match fld with + | Fnil -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnknownField), + (List.Cons ((Errors.CTX (PreIdentifiers.SymbolTag, id)), List.Nil)))) + | Fcons (id', t, fld') -> + (match AST.ident_eq id id' with + | Types.Inl _ -> Errors.OK (Coqlib.align pos (alignof t)) + | Types.Inr _ -> + field_offset_rec id fld' + (Nat.plus (Coqlib.align pos (alignof t)) (sizeof t))) + +(** val field_offset : AST.ident -> fieldlist -> Nat.nat Errors.res **) +let field_offset id fld = + field_offset_rec id fld Nat.O + +(** val field_type : AST.ident -> fieldlist -> type0 Errors.res **) +let rec field_type id = function +| Fnil -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.UnknownField), + (List.Cons ((Errors.CTX (PreIdentifiers.SymbolTag, id)), List.Nil)))) +| Fcons (id', t, fld') -> + (match AST.ident_eq id id' with + | Types.Inl _ -> Errors.OK t + | Types.Inr _ -> field_type id fld') + +(** val typ_of_type : type0 -> AST.typ **) +let typ_of_type = function +| Tvoid -> AST.ASTint (AST.I32, AST.Unsigned) +| Tint (sz, sg) -> AST.ASTint (sz, sg) +| Tpointer x -> AST.ASTptr +| Tarray (x, x0) -> AST.ASTptr +| Tfunction (x, x0) -> AST.ASTptr +| Tstruct (x, x0) -> AST.ASTint (AST.I32, AST.Unsigned) +| Tunion (x, x0) -> AST.ASTint (AST.I32, AST.Unsigned) +| Tcomp_ptr x -> AST.ASTptr + +(** val opttyp_of_type : type0 -> AST.typ Types.option **) +let opttyp_of_type = function +| Tvoid -> Types.None +| Tint (sz, sg) -> Types.Some (AST.ASTint (sz, sg)) +| Tpointer x -> Types.Some AST.ASTptr +| Tarray (x, x0) -> Types.Some AST.ASTptr +| Tfunction (x, x0) -> Types.Some AST.ASTptr +| Tstruct (x, x0) -> Types.None +| Tunion (x, x0) -> Types.None +| Tcomp_ptr x -> Types.Some AST.ASTptr + +(** val typlist_of_typelist : typelist -> AST.typ List.list **) +let rec typlist_of_typelist = function +| Tnil -> List.Nil +| Tcons (hd, tl0) -> List.Cons ((typ_of_type hd), (typlist_of_typelist tl0)) + +type mode = +| By_value of AST.typ +| By_reference +| By_nothing of AST.typ + +(** val mode_rect_Type4 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 **) +let rec mode_rect_Type4 h_By_value h_By_reference h_By_nothing x_4615 = function +| By_value t -> h_By_value t +| By_reference -> h_By_reference +| By_nothing t -> h_By_nothing t + +(** val mode_rect_Type5 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 **) +let rec mode_rect_Type5 h_By_value h_By_reference h_By_nothing x_4620 = function +| By_value t -> h_By_value t +| By_reference -> h_By_reference +| By_nothing t -> h_By_nothing t + +(** val mode_rect_Type3 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 **) +let rec mode_rect_Type3 h_By_value h_By_reference h_By_nothing x_4625 = function +| By_value t -> h_By_value t +| By_reference -> h_By_reference +| By_nothing t -> h_By_nothing t + +(** val mode_rect_Type2 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 **) +let rec mode_rect_Type2 h_By_value h_By_reference h_By_nothing x_4630 = function +| By_value t -> h_By_value t +| By_reference -> h_By_reference +| By_nothing t -> h_By_nothing t + +(** val mode_rect_Type1 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 **) +let rec mode_rect_Type1 h_By_value h_By_reference h_By_nothing x_4635 = function +| By_value t -> h_By_value t +| By_reference -> h_By_reference +| By_nothing t -> h_By_nothing t + +(** val mode_rect_Type0 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 **) +let rec mode_rect_Type0 h_By_value h_By_reference h_By_nothing x_4640 = function +| By_value t -> h_By_value t +| By_reference -> h_By_reference +| By_nothing t -> h_By_nothing t + +(** val mode_inv_rect_Type4 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 **) +let mode_inv_rect_Type4 x1 hterm h1 h2 h3 = + let hcut = mode_rect_Type4 h1 h2 h3 x1 hterm in hcut __ __ + +(** val mode_inv_rect_Type3 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 **) +let mode_inv_rect_Type3 x1 hterm h1 h2 h3 = + let hcut = mode_rect_Type3 h1 h2 h3 x1 hterm in hcut __ __ + +(** val mode_inv_rect_Type2 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 **) +let mode_inv_rect_Type2 x1 hterm h1 h2 h3 = + let hcut = mode_rect_Type2 h1 h2 h3 x1 hterm in hcut __ __ + +(** val mode_inv_rect_Type1 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 **) +let mode_inv_rect_Type1 x1 hterm h1 h2 h3 = + let hcut = mode_rect_Type1 h1 h2 h3 x1 hterm in hcut __ __ + +(** val mode_inv_rect_Type0 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 **) +let mode_inv_rect_Type0 x1 hterm h1 h2 h3 = + let hcut = mode_rect_Type0 h1 h2 h3 x1 hterm in hcut __ __ + +(** val mode_discr : AST.typ -> mode -> mode -> __ **) +let mode_discr a1 x y = + Logic.eq_rect_Type2 x + (match x with + | By_value a0 -> Obj.magic (fun _ dH -> dH __) + | By_reference -> Obj.magic (fun _ dH -> dH) + | By_nothing a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val mode_jmdiscr : AST.typ -> mode -> mode -> __ **) +let mode_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (match x with + | By_value a0 -> Obj.magic (fun _ dH -> dH __) + | By_reference -> Obj.magic (fun _ dH -> dH) + | By_nothing a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val access_mode : type0 -> mode **) +let access_mode = function +| Tvoid -> By_nothing (typ_of_type Tvoid) +| Tint (i, s) -> By_value (AST.ASTint (i, s)) +| Tpointer x -> By_value AST.ASTptr +| Tarray (x, x0) -> By_reference +| Tfunction (x, x0) -> By_reference +| Tstruct (x, fList) -> By_nothing (typ_of_type (Tstruct (x, fList))) +| Tunion (x, fList) -> By_nothing (typ_of_type (Tunion (x, fList))) +| Tcomp_ptr x -> By_value AST.ASTptr + +(** val signature_of_type : typelist -> type0 -> AST.signature **) +let signature_of_type args res = + { AST.sig_args = (typlist_of_typelist args); AST.sig_res = + (opttyp_of_type res) } + +(** val external_function : + AST.ident -> typelist -> type0 -> AST.external_function **) +let external_function id targs tres = + { AST.ef_id = id; AST.ef_sig = (signature_of_type targs tres) } + diff --git a/extracted/csyntax.mli b/extracted/csyntax.mli new file mode 100644 index 0000000..857b919 --- /dev/null +++ b/extracted/csyntax.mli @@ -0,0 +1,666 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Coqlib + +open CostLabel + +type type0 = +| Tvoid +| Tint of AST.intsize * AST.signedness +| Tpointer of type0 +| Tarray of type0 * Nat.nat +| Tfunction of typelist * type0 +| Tstruct of AST.ident * fieldlist +| Tunion of AST.ident * fieldlist +| Tcomp_ptr of AST.ident +and typelist = +| Tnil +| Tcons of type0 * typelist +and fieldlist = +| Fnil +| Fcons of AST.ident * type0 * fieldlist + +val type_inv_rect_Type4 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident + -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val type_inv_rect_Type3 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident + -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val type_inv_rect_Type2 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident + -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val type_inv_rect_Type1 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident + -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val type_inv_rect_Type0 : + type0 -> (__ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> 'a1) -> + (type0 -> __ -> 'a1) -> (type0 -> Nat.nat -> __ -> 'a1) -> (typelist -> + type0 -> __ -> 'a1) -> (AST.ident -> fieldlist -> __ -> 'a1) -> (AST.ident + -> fieldlist -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val typelist_inv_rect_Type4 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 + +val typelist_inv_rect_Type3 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 + +val typelist_inv_rect_Type2 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 + +val typelist_inv_rect_Type1 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 + +val typelist_inv_rect_Type0 : + typelist -> (__ -> 'a1) -> (type0 -> typelist -> __ -> 'a1) -> 'a1 + +val fieldlist_inv_rect_Type4 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> 'a1) + -> 'a1 + +val fieldlist_inv_rect_Type3 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> 'a1) + -> 'a1 + +val fieldlist_inv_rect_Type2 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> 'a1) + -> 'a1 + +val fieldlist_inv_rect_Type1 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> 'a1) + -> 'a1 + +val fieldlist_inv_rect_Type0 : + fieldlist -> (__ -> 'a1) -> (AST.ident -> type0 -> fieldlist -> __ -> 'a1) + -> 'a1 + +val type_discr : type0 -> type0 -> __ + +val typelist_discr : typelist -> typelist -> __ + +val fieldlist_discr : fieldlist -> fieldlist -> __ + +val type_jmdiscr : type0 -> type0 -> __ + +val typelist_jmdiscr : typelist -> typelist -> __ + +val fieldlist_jmdiscr : fieldlist -> fieldlist -> __ + +type unary_operation = +| Onotbool +| Onotint +| Oneg + +val unary_operation_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 + +val unary_operation_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 + +val unary_operation_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 + +val unary_operation_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 + +val unary_operation_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 + +val unary_operation_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> unary_operation -> 'a1 + +val unary_operation_inv_rect_Type4 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type3 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type2 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type1 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type0 : + unary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val unary_operation_discr : unary_operation -> unary_operation -> __ + +val unary_operation_jmdiscr : unary_operation -> unary_operation -> __ + +type binary_operation = +| Oadd +| Osub +| Omul +| Odiv +| Omod +| Oand +| Oor +| Oxor +| Oshl +| Oshr +| Oeq +| One +| Olt +| Ogt +| Ole +| Oge + +val binary_operation_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 + +val binary_operation_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 + +val binary_operation_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 + +val binary_operation_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 + +val binary_operation_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 + +val binary_operation_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> binary_operation -> 'a1 + +val binary_operation_inv_rect_Type4 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type3 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type2 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type1 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type0 : + binary_operation -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val binary_operation_discr : binary_operation -> binary_operation -> __ + +val binary_operation_jmdiscr : binary_operation -> binary_operation -> __ + +type expr = +| Expr of expr_descr * type0 +and expr_descr = +| Econst_int of AST.intsize * AST.bvint +| Evar of AST.ident +| Ederef of expr +| Eaddrof of expr +| Eunop of unary_operation * expr +| Ebinop of binary_operation * expr * expr +| Ecast of type0 * expr +| Econdition of expr * expr * expr +| Eandbool of expr * expr +| Eorbool of expr * expr +| Esizeof of type0 +| Efield of expr * AST.ident +| Ecost of CostLabel.costlabel * expr + +val expr_inv_rect_Type4 : expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 + +val expr_inv_rect_Type3 : expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 + +val expr_inv_rect_Type2 : expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 + +val expr_inv_rect_Type1 : expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 + +val expr_inv_rect_Type0 : expr -> (expr_descr -> type0 -> __ -> 'a1) -> 'a1 + +val expr_descr_inv_rect_Type4 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) -> + (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> __ + -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> expr + -> __ -> 'a1) -> 'a1 + +val expr_descr_inv_rect_Type3 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) -> + (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> __ + -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> expr + -> __ -> 'a1) -> 'a1 + +val expr_descr_inv_rect_Type2 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) -> + (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> __ + -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> expr + -> __ -> 'a1) -> 'a1 + +val expr_descr_inv_rect_Type1 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) -> + (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> __ + -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> expr + -> __ -> 'a1) -> 'a1 + +val expr_descr_inv_rect_Type0 : + expr_descr -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (expr -> __ -> 'a1) -> (expr -> __ -> 'a1) -> (unary_operation + -> expr -> __ -> 'a1) -> (binary_operation -> expr -> expr -> __ -> 'a1) -> + (type0 -> expr -> __ -> 'a1) -> (expr -> expr -> expr -> __ -> 'a1) -> + (expr -> expr -> __ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (type0 -> __ + -> 'a1) -> (expr -> AST.ident -> __ -> 'a1) -> (CostLabel.costlabel -> expr + -> __ -> 'a1) -> 'a1 + +val expr_discr : expr -> expr -> __ + +val expr_descr_discr : expr_descr -> expr_descr -> __ + +val expr_jmdiscr : expr -> expr -> __ + +val expr_descr_jmdiscr : expr_descr -> expr_descr -> __ + +val typeof : expr -> type0 + +type label = AST.ident + +type statement = +| Sskip +| Sassign of expr * expr +| Scall of expr Types.option * expr * expr List.list +| Ssequence of statement * statement +| Sifthenelse of expr * statement * statement +| Swhile of expr * statement +| Sdowhile of expr * statement +| Sfor of statement * expr * statement * statement +| Sbreak +| Scontinue +| Sreturn of expr Types.option +| Sswitch of expr * labeled_statements +| Slabel of label * statement +| Sgoto of label +| Scost of CostLabel.costlabel * statement +and labeled_statements = +| LSdefault of statement +| LScase of AST.intsize * AST.bvint * statement * labeled_statements + +val statement_inv_rect_Type4 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) -> + (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) -> + (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) -> + 'a1 + +val statement_inv_rect_Type3 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) -> + (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) -> + (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) -> + 'a1 + +val statement_inv_rect_Type2 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) -> + (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) -> + (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) -> + 'a1 + +val statement_inv_rect_Type1 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) -> + (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) -> + (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) -> + 'a1 + +val statement_inv_rect_Type0 : + statement -> (__ -> 'a1) -> (expr -> expr -> __ -> 'a1) -> (expr + Types.option -> expr -> expr List.list -> __ -> 'a1) -> (statement -> + statement -> __ -> 'a1) -> (expr -> statement -> statement -> __ -> 'a1) -> + (expr -> statement -> __ -> 'a1) -> (expr -> statement -> __ -> 'a1) -> + (statement -> expr -> statement -> statement -> __ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (expr Types.option -> __ -> 'a1) -> (expr -> + labeled_statements -> __ -> 'a1) -> (label -> statement -> __ -> 'a1) -> + (label -> __ -> 'a1) -> (CostLabel.costlabel -> statement -> __ -> 'a1) -> + 'a1 + +val labeled_statements_inv_rect_Type4 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> AST.bvint + -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 + +val labeled_statements_inv_rect_Type3 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> AST.bvint + -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 + +val labeled_statements_inv_rect_Type2 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> AST.bvint + -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 + +val labeled_statements_inv_rect_Type1 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> AST.bvint + -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 + +val labeled_statements_inv_rect_Type0 : + labeled_statements -> (statement -> __ -> 'a1) -> (AST.intsize -> AST.bvint + -> statement -> labeled_statements -> __ -> 'a1) -> 'a1 + +val statement_discr : statement -> statement -> __ + +val labeled_statements_discr : labeled_statements -> labeled_statements -> __ + +val statement_jmdiscr : statement -> statement -> __ + +val labeled_statements_jmdiscr : + labeled_statements -> labeled_statements -> __ + +type function0 = { fn_return : type0; + fn_params : (AST.ident, type0) Types.prod List.list; + fn_vars : (AST.ident, type0) Types.prod List.list; + fn_body : statement } + +val function_rect_Type4 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 + +val function_rect_Type5 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 + +val function_rect_Type3 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 + +val function_rect_Type2 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 + +val function_rect_Type1 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 + +val function_rect_Type0 : + (type0 -> (AST.ident, type0) Types.prod List.list -> (AST.ident, type0) + Types.prod List.list -> statement -> 'a1) -> function0 -> 'a1 + +val fn_return : function0 -> type0 + +val fn_params : function0 -> (AST.ident, type0) Types.prod List.list + +val fn_vars : function0 -> (AST.ident, type0) Types.prod List.list + +val fn_body : function0 -> statement + +val function_inv_rect_Type4 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 + +val function_inv_rect_Type3 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 + +val function_inv_rect_Type2 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 + +val function_inv_rect_Type1 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 + +val function_inv_rect_Type0 : + function0 -> (type0 -> (AST.ident, type0) Types.prod List.list -> + (AST.ident, type0) Types.prod List.list -> statement -> __ -> 'a1) -> 'a1 + +val function_discr : function0 -> function0 -> __ + +val function_jmdiscr : function0 -> function0 -> __ + +type clight_fundef = +| CL_Internal of function0 +| CL_External of AST.ident * typelist * type0 + +val clight_fundef_rect_Type4 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 + +val clight_fundef_rect_Type5 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 + +val clight_fundef_rect_Type3 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 + +val clight_fundef_rect_Type2 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 + +val clight_fundef_rect_Type1 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 + +val clight_fundef_rect_Type0 : + (function0 -> 'a1) -> (AST.ident -> typelist -> type0 -> 'a1) -> + clight_fundef -> 'a1 + +val clight_fundef_inv_rect_Type4 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 + +val clight_fundef_inv_rect_Type3 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 + +val clight_fundef_inv_rect_Type2 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 + +val clight_fundef_inv_rect_Type1 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 + +val clight_fundef_inv_rect_Type0 : + clight_fundef -> (function0 -> __ -> 'a1) -> (AST.ident -> typelist -> + type0 -> __ -> 'a1) -> 'a1 + +val clight_fundef_discr : clight_fundef -> clight_fundef -> __ + +val clight_fundef_jmdiscr : clight_fundef -> clight_fundef -> __ + +type clight_program = + (clight_fundef, (AST.init_data List.list, type0) Types.prod) AST.program + +val type_of_params : (AST.ident, type0) Types.prod List.list -> typelist + +val type_of_function : function0 -> type0 + +val type_of_fundef : clight_fundef -> type0 + +val alignof_fields : fieldlist -> Nat.nat + +val alignof : type0 -> Nat.nat + +val sizeof_union : fieldlist -> Nat.nat + +val sizeof_struct : fieldlist -> Nat.nat -> Nat.nat + +val sizeof : type0 -> Nat.nat + +val field_offset_rec : + AST.ident -> fieldlist -> Nat.nat -> Nat.nat Errors.res + +val field_offset : AST.ident -> fieldlist -> Nat.nat Errors.res + +val field_type : AST.ident -> fieldlist -> type0 Errors.res + +val typ_of_type : type0 -> AST.typ + +val opttyp_of_type : type0 -> AST.typ Types.option + +val typlist_of_typelist : typelist -> AST.typ List.list + +type mode = +| By_value of AST.typ +| By_reference +| By_nothing of AST.typ + +val mode_rect_Type4 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 + +val mode_rect_Type5 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 + +val mode_rect_Type3 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 + +val mode_rect_Type2 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 + +val mode_rect_Type1 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 + +val mode_rect_Type0 : + (AST.typ -> 'a1) -> 'a1 -> (AST.typ -> 'a1) -> AST.typ -> mode -> 'a1 + +val mode_inv_rect_Type4 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 + +val mode_inv_rect_Type3 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 + +val mode_inv_rect_Type2 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 + +val mode_inv_rect_Type1 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 + +val mode_inv_rect_Type0 : + AST.typ -> mode -> (AST.typ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> + (AST.typ -> __ -> __ -> 'a1) -> 'a1 + +val mode_discr : AST.typ -> mode -> mode -> __ + +val mode_jmdiscr : AST.typ -> mode -> mode -> __ + +val access_mode : type0 -> mode + +val signature_of_type : typelist -> type0 -> AST.signature + +val external_function : + AST.ident -> typelist -> type0 -> AST.external_function + diff --git a/extracted/deqsets.ml b/extracted/deqsets.ml new file mode 100644 index 0000000..38f28e6 --- /dev/null +++ b/extracted/deqsets.ml @@ -0,0 +1,144 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Relations + +open Bool + +type deqSet = + __ -> __ -> Bool.bool + (* singleton inductive, whose constructor was mk_DeqSet *) + +(** val deqSet_rect_Type4 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 **) +let rec deqSet_rect_Type4 h_mk_DeqSet x_3369 = + let eqb = x_3369 in h_mk_DeqSet __ eqb __ + +(** val deqSet_rect_Type5 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 **) +let rec deqSet_rect_Type5 h_mk_DeqSet x_3371 = + let eqb = x_3371 in h_mk_DeqSet __ eqb __ + +(** val deqSet_rect_Type3 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 **) +let rec deqSet_rect_Type3 h_mk_DeqSet x_3373 = + let eqb = x_3373 in h_mk_DeqSet __ eqb __ + +(** val deqSet_rect_Type2 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 **) +let rec deqSet_rect_Type2 h_mk_DeqSet x_3375 = + let eqb = x_3375 in h_mk_DeqSet __ eqb __ + +(** val deqSet_rect_Type1 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 **) +let rec deqSet_rect_Type1 h_mk_DeqSet x_3377 = + let eqb = x_3377 in h_mk_DeqSet __ eqb __ + +(** val deqSet_rect_Type0 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 **) +let rec deqSet_rect_Type0 h_mk_DeqSet x_3379 = + let eqb = x_3379 in h_mk_DeqSet __ eqb __ + +type carr = __ + +(** val eqb : deqSet -> __ -> __ -> Bool.bool **) +let rec eqb xxx = + let yyy = xxx in yyy + +(** val deqSet_inv_rect_Type4 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 **) +let deqSet_inv_rect_Type4 hterm h1 = + let hcut = deqSet_rect_Type4 h1 hterm in hcut __ + +(** val deqSet_inv_rect_Type3 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 **) +let deqSet_inv_rect_Type3 hterm h1 = + let hcut = deqSet_rect_Type3 h1 hterm in hcut __ + +(** val deqSet_inv_rect_Type2 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 **) +let deqSet_inv_rect_Type2 hterm h1 = + let hcut = deqSet_rect_Type2 h1 hterm in hcut __ + +(** val deqSet_inv_rect_Type1 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 **) +let deqSet_inv_rect_Type1 hterm h1 = + let hcut = deqSet_rect_Type1 h1 hterm in hcut __ + +(** val deqSet_inv_rect_Type0 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 **) +let deqSet_inv_rect_Type0 hterm h1 = + let hcut = deqSet_rect_Type0 h1 hterm in hcut __ + +(** val beqb : Bool.bool -> Bool.bool -> Bool.bool **) +let beqb b1 b2 = + match b1 with + | Bool.True -> b2 + | Bool.False -> Bool.notb b2 + +(** val deqBool : deqSet **) +let deqBool = + Obj.magic beqb + +(** val eq_option : + deqSet -> __ Types.option -> __ Types.option -> Bool.bool **) +let eq_option a a1 a2 = + match a1 with + | Types.None -> + (match a2 with + | Types.None -> Bool.True + | Types.Some x -> Bool.False) + | Types.Some a1' -> + (match a2 with + | Types.None -> Bool.False + | Types.Some a2' -> eqb a a1' a2') + +(** val deqOption : deqSet -> deqSet **) +let deqOption a = + Obj.magic (eq_option a) + +(** val eq_pairs : + deqSet -> deqSet -> (__, __) Types.prod -> (__, __) Types.prod -> + Bool.bool **) +let eq_pairs a b p1 p2 = + Bool.andb (eqb a p1.Types.fst p2.Types.fst) + (eqb b p1.Types.snd p2.Types.snd) + +(** val deqProd : deqSet -> deqSet -> deqSet **) +let deqProd a b = + Obj.magic (eq_pairs a b) + +(** val eq_sum : + deqSet -> deqSet -> (__, __) Types.sum -> (__, __) Types.sum -> Bool.bool **) +let eq_sum a b p1 p2 = + match p1 with + | Types.Inl a1 -> + (match p2 with + | Types.Inl a2 -> eqb a a1 a2 + | Types.Inr b2 -> Bool.False) + | Types.Inr b1 -> + (match p2 with + | Types.Inl a2 -> Bool.False + | Types.Inr b2 -> eqb b b1 b2) + +(** val deqSum : deqSet -> deqSet -> deqSet **) +let deqSum a b = + Obj.magic (eq_sum a b) + +(** val eq_sigma : deqSet -> __ Types.sig0 -> __ Types.sig0 -> Bool.bool **) +let eq_sigma a p1 p2 = + let a1 = p1 in let a2 = p2 in eqb a a1 a2 + +(** val deqSig : deqSet -> deqSet **) +let deqSig a = + Obj.magic (eq_sigma a) + diff --git a/extracted/deqsets.mli b/extracted/deqsets.mli new file mode 100644 index 0000000..6cd9bee --- /dev/null +++ b/extracted/deqsets.mli @@ -0,0 +1,79 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Relations + +open Bool + +type deqSet = + __ -> __ -> Bool.bool + (* singleton inductive, whose constructor was mk_DeqSet *) + +val deqSet_rect_Type4 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 + +val deqSet_rect_Type5 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 + +val deqSet_rect_Type3 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 + +val deqSet_rect_Type2 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 + +val deqSet_rect_Type1 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 + +val deqSet_rect_Type0 : + (__ -> (__ -> __ -> Bool.bool) -> __ -> 'a1) -> deqSet -> 'a1 + +type carr + +val eqb : deqSet -> __ -> __ -> Bool.bool + +val deqSet_inv_rect_Type4 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 + +val deqSet_inv_rect_Type3 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 + +val deqSet_inv_rect_Type2 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 + +val deqSet_inv_rect_Type1 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 + +val deqSet_inv_rect_Type0 : + deqSet -> (__ -> (__ -> __ -> Bool.bool) -> __ -> __ -> 'a1) -> 'a1 + +val beqb : Bool.bool -> Bool.bool -> Bool.bool + +val deqBool : deqSet + +val eq_option : deqSet -> __ Types.option -> __ Types.option -> Bool.bool + +val deqOption : deqSet -> deqSet + +val eq_pairs : + deqSet -> deqSet -> (__, __) Types.prod -> (__, __) Types.prod -> Bool.bool + +val deqProd : deqSet -> deqSet -> deqSet + +val eq_sum : + deqSet -> deqSet -> (__, __) Types.sum -> (__, __) Types.sum -> Bool.bool + +val deqSum : deqSet -> deqSet -> deqSet + +val eq_sigma : deqSet -> __ Types.sig0 -> __ Types.sig0 -> Bool.bool + +val deqSig : deqSet -> deqSet + diff --git a/extracted/deqsets_extra.ml b/extracted/deqsets_extra.ml new file mode 100644 index 0000000..de64523 --- /dev/null +++ b/extracted/deqsets_extra.ml @@ -0,0 +1,41 @@ +open Preamble + +open Relations + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Deqsets + +open Sets + +open Nat + +open List + +open Listb + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +(** val eqb_elim : + Deqsets.deqSet -> __ -> __ -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let eqb_elim d x y t f = + (match Deqsets.eqb d x y with + | Bool.True -> (fun _ -> t __) + | Bool.False -> (fun _ -> f __)) __ + diff --git a/extracted/deqsets_extra.mli b/extracted/deqsets_extra.mli new file mode 100644 index 0000000..9155a95 --- /dev/null +++ b/extracted/deqsets_extra.mli @@ -0,0 +1,37 @@ +open Preamble + +open Relations + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Deqsets + +open Sets + +open Nat + +open List + +open Listb + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +val eqb_elim : + Deqsets.deqSet -> __ -> __ -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + diff --git a/extracted/div_and_mod.ml b/extracted/div_and_mod.ml new file mode 100644 index 0000000..40c7812 --- /dev/null +++ b/extracted/div_and_mod.ml @@ -0,0 +1,109 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +(** val mod_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat **) +let rec mod_aux p m n = + match p with + | Nat.O -> m + | Nat.S q -> + (match Nat.leb m n with + | Bool.True -> m + | Bool.False -> mod_aux q (Nat.minus m (Nat.S n)) n) + +(** val mod0 : Nat.nat -> Nat.nat -> Nat.nat **) +let mod0 n = function +| Nat.O -> n +| Nat.S p -> mod_aux n n p + +(** val div_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat **) +let rec div_aux p m n = + match p with + | Nat.O -> Nat.O + | Nat.S q -> + (match Nat.leb m n with + | Bool.True -> Nat.O + | Bool.False -> Nat.S (div_aux q (Nat.minus m (Nat.S n)) n)) + +(** val div : Nat.nat -> Nat.nat -> Nat.nat **) +let div n = function +| Nat.O -> Nat.S n +| Nat.S p -> div_aux n n p + +(** val div_mod_spec_rect_Type4 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 **) +let rec div_mod_spec_rect_Type4 n m q r h_div_mod_spec_intro = + h_div_mod_spec_intro __ __ + +(** val div_mod_spec_rect_Type5 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 **) +let rec div_mod_spec_rect_Type5 n m q r h_div_mod_spec_intro = + h_div_mod_spec_intro __ __ + +(** val div_mod_spec_rect_Type3 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 **) +let rec div_mod_spec_rect_Type3 n m q r h_div_mod_spec_intro = + h_div_mod_spec_intro __ __ + +(** val div_mod_spec_rect_Type2 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 **) +let rec div_mod_spec_rect_Type2 n m q r h_div_mod_spec_intro = + h_div_mod_spec_intro __ __ + +(** val div_mod_spec_rect_Type1 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 **) +let rec div_mod_spec_rect_Type1 n m q r h_div_mod_spec_intro = + h_div_mod_spec_intro __ __ + +(** val div_mod_spec_rect_Type0 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 **) +let rec div_mod_spec_rect_Type0 n m q r h_div_mod_spec_intro = + h_div_mod_spec_intro __ __ + +(** val div_mod_spec_inv_rect_Type4 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let div_mod_spec_inv_rect_Type4 x1 x2 x3 x4 h1 = + let hcut = div_mod_spec_rect_Type4 x1 x2 x3 x4 h1 in hcut __ + +(** val div_mod_spec_inv_rect_Type3 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let div_mod_spec_inv_rect_Type3 x1 x2 x3 x4 h1 = + let hcut = div_mod_spec_rect_Type3 x1 x2 x3 x4 h1 in hcut __ + +(** val div_mod_spec_inv_rect_Type2 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let div_mod_spec_inv_rect_Type2 x1 x2 x3 x4 h1 = + let hcut = div_mod_spec_rect_Type2 x1 x2 x3 x4 h1 in hcut __ + +(** val div_mod_spec_inv_rect_Type1 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let div_mod_spec_inv_rect_Type1 x1 x2 x3 x4 h1 = + let hcut = div_mod_spec_rect_Type1 x1 x2 x3 x4 h1 in hcut __ + +(** val div_mod_spec_inv_rect_Type0 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> + 'a1 **) +let div_mod_spec_inv_rect_Type0 x1 x2 x3 x4 h1 = + let hcut = div_mod_spec_rect_Type0 x1 x2 x3 x4 h1 in hcut __ + +(** val div_mod_spec_discr : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> __ **) +let div_mod_spec_discr a1 a2 a3 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __)) __ + diff --git a/extracted/div_and_mod.mli b/extracted/div_and_mod.mli new file mode 100644 index 0000000..110b172 --- /dev/null +++ b/extracted/div_and_mod.mli @@ -0,0 +1,59 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +val mod_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat + +val mod0 : Nat.nat -> Nat.nat -> Nat.nat + +val div_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat + +val div : Nat.nat -> Nat.nat -> Nat.nat + +val div_mod_spec_rect_Type4 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_rect_Type5 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_rect_Type3 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_rect_Type2 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_rect_Type1 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_rect_Type0 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_inv_rect_Type4 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_inv_rect_Type3 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_inv_rect_Type2 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_inv_rect_Type1 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_inv_rect_Type0 : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val div_mod_spec_discr : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat -> __ + diff --git a/extracted/division.ml b/extracted/division.ml new file mode 100644 index 0000000..6be4412 --- /dev/null +++ b/extracted/division.ml @@ -0,0 +1,251 @@ +open Preamble + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +type natp = +| Pzero +| Ppos of Positive.pos + +(** val natp_rect_Type4 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 **) +let rec natp_rect_Type4 h_pzero h_ppos = function +| Pzero -> h_pzero +| Ppos x_4901 -> h_ppos x_4901 + +(** val natp_rect_Type5 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 **) +let rec natp_rect_Type5 h_pzero h_ppos = function +| Pzero -> h_pzero +| Ppos x_4905 -> h_ppos x_4905 + +(** val natp_rect_Type3 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 **) +let rec natp_rect_Type3 h_pzero h_ppos = function +| Pzero -> h_pzero +| Ppos x_4909 -> h_ppos x_4909 + +(** val natp_rect_Type2 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 **) +let rec natp_rect_Type2 h_pzero h_ppos = function +| Pzero -> h_pzero +| Ppos x_4913 -> h_ppos x_4913 + +(** val natp_rect_Type1 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 **) +let rec natp_rect_Type1 h_pzero h_ppos = function +| Pzero -> h_pzero +| Ppos x_4917 -> h_ppos x_4917 + +(** val natp_rect_Type0 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 **) +let rec natp_rect_Type0 h_pzero h_ppos = function +| Pzero -> h_pzero +| Ppos x_4921 -> h_ppos x_4921 + +(** val natp_inv_rect_Type4 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let natp_inv_rect_Type4 hterm h1 h2 = + let hcut = natp_rect_Type4 h1 h2 hterm in hcut __ + +(** val natp_inv_rect_Type3 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let natp_inv_rect_Type3 hterm h1 h2 = + let hcut = natp_rect_Type3 h1 h2 hterm in hcut __ + +(** val natp_inv_rect_Type2 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let natp_inv_rect_Type2 hterm h1 h2 = + let hcut = natp_rect_Type2 h1 h2 hterm in hcut __ + +(** val natp_inv_rect_Type1 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let natp_inv_rect_Type1 hterm h1 h2 = + let hcut = natp_rect_Type1 h1 h2 hterm in hcut __ + +(** val natp_inv_rect_Type0 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let natp_inv_rect_Type0 hterm h1 h2 = + let hcut = natp_rect_Type0 h1 h2 hterm in hcut __ + +(** val natp_discr : natp -> natp -> __ **) +let natp_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Pzero -> Obj.magic (fun _ dH -> dH) + | Ppos a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val natp0 : natp -> natp **) +let natp0 = function +| Pzero -> Pzero +| Ppos m -> Ppos (Positive.P0 m) + +(** val natp1 : natp -> natp **) +let natp1 = function +| Pzero -> Ppos Positive.One +| Ppos m -> Ppos (Positive.P1 m) + +(** val divide : Positive.pos -> Positive.pos -> (natp, natp) Types.prod **) +let rec divide m n = + match m with + | Positive.One -> + (match n with + | Positive.One -> { Types.fst = (Ppos Positive.One); Types.snd = Pzero } + | Positive.P1 x -> + { Types.fst = Pzero; Types.snd = (Ppos Positive.One) } + | Positive.P0 x -> + { Types.fst = Pzero; Types.snd = (Ppos Positive.One) }) + | Positive.P1 m' -> + let { Types.fst = q; Types.snd = r } = divide m' n in + (match r with + | Pzero -> + (match n with + | Positive.One -> { Types.fst = (natp1 q); Types.snd = Pzero } + | Positive.P1 x -> + { Types.fst = (natp0 q); Types.snd = (Ppos Positive.One) } + | Positive.P0 x -> + { Types.fst = (natp0 q); Types.snd = (Ppos Positive.One) }) + | Ppos r' -> + (match Positive.partial_minus (Positive.P1 r') n with + | Positive.MinusNeg -> + { Types.fst = (natp0 q); Types.snd = (Ppos (Positive.P1 r')) } + | Positive.MinusZero -> { Types.fst = (natp1 q); Types.snd = Pzero } + | Positive.MinusPos r'' -> + { Types.fst = (natp1 q); Types.snd = (Ppos r'') })) + | Positive.P0 m' -> + let { Types.fst = q; Types.snd = r } = divide m' n in + (match r with + | Pzero -> { Types.fst = (natp0 q); Types.snd = Pzero } + | Ppos r' -> + (match Positive.partial_minus (Positive.P0 r') n with + | Positive.MinusNeg -> + { Types.fst = (natp0 q); Types.snd = (Ppos (Positive.P0 r')) } + | Positive.MinusZero -> { Types.fst = (natp1 q); Types.snd = Pzero } + | Positive.MinusPos r'' -> + { Types.fst = (natp1 q); Types.snd = (Ppos r'') })) + +(** val div : Positive.pos -> Positive.pos -> natp **) +let div m n = + (divide m n).Types.fst + +(** val mod0 : Positive.pos -> Positive.pos -> natp **) +let mod0 m n = + (divide m n).Types.snd + +(** val natp_plus : natp -> natp -> natp **) +let rec natp_plus n m = + match n with + | Pzero -> m + | Ppos n' -> + (match m with + | Pzero -> n + | Ppos m' -> Ppos (Positive.plus n' m')) + +(** val natp_times : natp -> natp -> natp **) +let rec natp_times n m = + match n with + | Pzero -> Pzero + | Ppos n' -> + (match m with + | Pzero -> Pzero + | Ppos m' -> Ppos (Positive.times n' m')) + +(** val dec_divides : Positive.pos -> Positive.pos -> (__, __) Types.sum **) +let dec_divides m n = + Types.prod_rect_Type0 (fun dv md -> + match md with + | Pzero -> + (match dv with + | Pzero -> (fun _ -> Obj.magic natp_discr (Ppos n) Pzero __ __) + | Ppos dv' -> (fun _ -> Types.Inl __)) + | Ppos x -> + (match dv with + | Pzero -> (fun md' _ -> Types.Inr __) + | Ppos md' -> (fun dv' _ -> Types.Inr __)) x) (divide n m) __ + +(** val dec_dividesZ : Z.z -> Z.z -> (__, __) Types.sum **) +let dec_dividesZ p q = + match p with + | Z.OZ -> + (match q with + | Z.OZ -> Types.Inr __ + | Z.Pos m -> Types.Inr __ + | Z.Neg m -> Types.Inr __) + | Z.Pos n -> + (match q with + | Z.OZ -> Types.Inl __ + | Z.Pos auto -> dec_divides n auto + | Z.Neg auto -> dec_divides n auto) + | Z.Neg n -> + (match q with + | Z.OZ -> Types.Inl __ + | Z.Pos auto -> dec_divides n auto + | Z.Neg auto -> dec_divides n auto) + +(** val natp_to_Z : natp -> Z.z **) +let natp_to_Z = function +| Pzero -> Z.OZ +| Ppos p -> Z.Pos p + +(** val natp_to_negZ : natp -> Z.z **) +let natp_to_negZ = function +| Pzero -> Z.OZ +| Ppos p -> Z.Neg p + +(** val divZ : Z.z -> Z.z -> Z.z **) +let divZ x y = + match x with + | Z.OZ -> Z.OZ + | Z.Pos n -> + (match y with + | Z.OZ -> Z.OZ + | Z.Pos m -> natp_to_Z (divide n m).Types.fst + | Z.Neg m -> + let { Types.fst = q; Types.snd = r } = divide n m in + (match r with + | Pzero -> natp_to_negZ q + | Ppos x0 -> Z.zpred (natp_to_negZ q))) + | Z.Neg n -> + (match y with + | Z.OZ -> Z.OZ + | Z.Pos m -> + let { Types.fst = q; Types.snd = r } = divide n m in + (match r with + | Pzero -> natp_to_negZ q + | Ppos x0 -> Z.zpred (natp_to_negZ q)) + | Z.Neg m -> natp_to_Z (divide n m).Types.fst) + +(** val modZ : Z.z -> Z.z -> Z.z **) +let modZ x y = + match x with + | Z.OZ -> Z.OZ + | Z.Pos n -> + (match y with + | Z.OZ -> Z.OZ + | Z.Pos m -> natp_to_Z (divide n m).Types.snd + | Z.Neg m -> + let { Types.fst = q; Types.snd = r } = divide n m in + (match r with + | Pzero -> Z.OZ + | Ppos x0 -> Z.zplus y (natp_to_Z r))) + | Z.Neg n -> + (match y with + | Z.OZ -> Z.OZ + | Z.Pos m -> + let { Types.fst = q; Types.snd = r } = divide n m in + (match r with + | Pzero -> Z.OZ + | Ppos x0 -> Z.zminus y (natp_to_Z r)) + | Z.Neg m -> natp_to_Z (divide n m).Types.snd) + diff --git a/extracted/division.mli b/extracted/division.mli new file mode 100644 index 0000000..a89dd34 --- /dev/null +++ b/extracted/division.mli @@ -0,0 +1,81 @@ +open Preamble + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +type natp = +| Pzero +| Ppos of Positive.pos + +val natp_rect_Type4 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 + +val natp_rect_Type5 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 + +val natp_rect_Type3 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 + +val natp_rect_Type2 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 + +val natp_rect_Type1 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 + +val natp_rect_Type0 : 'a1 -> (Positive.pos -> 'a1) -> natp -> 'a1 + +val natp_inv_rect_Type4 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val natp_inv_rect_Type3 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val natp_inv_rect_Type2 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val natp_inv_rect_Type1 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val natp_inv_rect_Type0 : + natp -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val natp_discr : natp -> natp -> __ + +val natp0 : natp -> natp + +val natp1 : natp -> natp + +val divide : Positive.pos -> Positive.pos -> (natp, natp) Types.prod + +val div : Positive.pos -> Positive.pos -> natp + +val mod0 : Positive.pos -> Positive.pos -> natp + +val natp_plus : natp -> natp -> natp + +val natp_times : natp -> natp -> natp + +val dec_divides : Positive.pos -> Positive.pos -> (__, __) Types.sum + +val dec_dividesZ : Z.z -> Z.z -> (__, __) Types.sum + +val natp_to_Z : natp -> Z.z + +val natp_to_negZ : natp -> Z.z + +val divZ : Z.z -> Z.z -> Z.z + +val modZ : Z.z -> Z.z -> Z.z + diff --git a/extracted/eRTL.ml b/extracted/eRTL.ml new file mode 100644 index 0000000..e604294 --- /dev/null +++ b/extracted/eRTL.ml @@ -0,0 +1,710 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type move_dst = +| PSD of Registers.register +| HDW of I8051.register + +(** val move_dst_rect_Type4 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 **) +let rec move_dst_rect_Type4 h_PSD h_HDW = function +| PSD x_18499 -> h_PSD x_18499 +| HDW x_18500 -> h_HDW x_18500 + +(** val move_dst_rect_Type5 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 **) +let rec move_dst_rect_Type5 h_PSD h_HDW = function +| PSD x_18504 -> h_PSD x_18504 +| HDW x_18505 -> h_HDW x_18505 + +(** val move_dst_rect_Type3 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 **) +let rec move_dst_rect_Type3 h_PSD h_HDW = function +| PSD x_18509 -> h_PSD x_18509 +| HDW x_18510 -> h_HDW x_18510 + +(** val move_dst_rect_Type2 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 **) +let rec move_dst_rect_Type2 h_PSD h_HDW = function +| PSD x_18514 -> h_PSD x_18514 +| HDW x_18515 -> h_HDW x_18515 + +(** val move_dst_rect_Type1 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 **) +let rec move_dst_rect_Type1 h_PSD h_HDW = function +| PSD x_18519 -> h_PSD x_18519 +| HDW x_18520 -> h_HDW x_18520 + +(** val move_dst_rect_Type0 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 **) +let rec move_dst_rect_Type0 h_PSD h_HDW = function +| PSD x_18524 -> h_PSD x_18524 +| HDW x_18525 -> h_HDW x_18525 + +(** val move_dst_inv_rect_Type4 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 **) +let move_dst_inv_rect_Type4 hterm h1 h2 = + let hcut = move_dst_rect_Type4 h1 h2 hterm in hcut __ + +(** val move_dst_inv_rect_Type3 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 **) +let move_dst_inv_rect_Type3 hterm h1 h2 = + let hcut = move_dst_rect_Type3 h1 h2 hterm in hcut __ + +(** val move_dst_inv_rect_Type2 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 **) +let move_dst_inv_rect_Type2 hterm h1 h2 = + let hcut = move_dst_rect_Type2 h1 h2 hterm in hcut __ + +(** val move_dst_inv_rect_Type1 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 **) +let move_dst_inv_rect_Type1 hterm h1 h2 = + let hcut = move_dst_rect_Type1 h1 h2 hterm in hcut __ + +(** val move_dst_inv_rect_Type0 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 **) +let move_dst_inv_rect_Type0 hterm h1 h2 = + let hcut = move_dst_rect_Type0 h1 h2 hterm in hcut __ + +(** val move_dst_discr : move_dst -> move_dst -> __ **) +let move_dst_discr x y = + Logic.eq_rect_Type2 x + (match x with + | PSD a0 -> Obj.magic (fun _ dH -> dH __) + | HDW a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val move_dst_jmdiscr : move_dst -> move_dst -> __ **) +let move_dst_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | PSD a0 -> Obj.magic (fun _ dH -> dH __) + | HDW a0 -> Obj.magic (fun _ dH -> dH __)) y + +type move_src = move_dst Joint.argument + +(** val move_src_from_dst : move_dst -> move_src **) +let move_src_from_dst x = + Joint.Reg x + +(** val dpi1__o__move_dst_to_src__o__inject : + (move_dst, 'a1) Types.dPair -> move_src Types.sig0 **) +let dpi1__o__move_dst_to_src__o__inject x2 = + move_src_from_dst x2.Types.dpi1 + +(** val eject__o__move_dst_to_src__o__inject : + move_dst Types.sig0 -> move_src Types.sig0 **) +let eject__o__move_dst_to_src__o__inject x2 = + move_src_from_dst (Types.pi1 x2) + +(** val move_dst_to_src__o__inject : move_dst -> move_src Types.sig0 **) +let move_dst_to_src__o__inject x1 = + move_src_from_dst x1 + +(** val dpi1__o__move_dst_to_src : + (move_dst, 'a1) Types.dPair -> move_src **) +let dpi1__o__move_dst_to_src x1 = + move_src_from_dst x1.Types.dpi1 + +(** val eject__o__move_dst_to_src : move_dst Types.sig0 -> move_src **) +let eject__o__move_dst_to_src x1 = + move_src_from_dst (Types.pi1 x1) + +(** val psd_argument_move_src : Joint.psd_argument -> move_src **) +let psd_argument_move_src = function +| Joint.Reg r -> Joint.Reg (PSD r) +| Joint.Imm b -> Joint.Imm b + +(** val byte_to_psd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte -> move_src Types.sig0 **) +let byte_to_psd_argument__o__psd_argument_to_move_src__o__inject x0 = + psd_argument_move_src (Joint.psd_argument_from_byte x0) + +(** val dpi1__o__byte_to_hdw_argument__o__psd_argument_to_move_src__o__inject : + (BitVector.byte, 'a1) Types.dPair -> move_src Types.sig0 **) +let dpi1__o__byte_to_hdw_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src (Joint.dpi1__o__byte_to_hdw_argument x2) + +(** val dpi1__o__byte_to_psd_argument__o__psd_argument_to_move_src__o__inject : + (BitVector.byte, 'a1) Types.dPair -> move_src Types.sig0 **) +let dpi1__o__byte_to_psd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src (Joint.dpi1__o__byte_to_psd_argument x2) + +(** val dpi1__o__reg_to_psd_argument__o__psd_argument_to_move_src__o__inject : + (Registers.register, 'a1) Types.dPair -> move_src Types.sig0 **) +let dpi1__o__reg_to_psd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src (Joint.dpi1__o__reg_to_psd_argument x2) + +(** val eject__o__byte_to_hdw_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte Types.sig0 -> move_src Types.sig0 **) +let eject__o__byte_to_hdw_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src (Joint.eject__o__byte_to_hdw_argument x2) + +(** val eject__o__byte_to_psd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte Types.sig0 -> move_src Types.sig0 **) +let eject__o__byte_to_psd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src (Joint.eject__o__byte_to_psd_argument x2) + +(** val eject__o__reg_to_psd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register Types.sig0 -> move_src Types.sig0 **) +let eject__o__reg_to_psd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src (Joint.eject__o__reg_to_psd_argument x2) + +(** val reg_to_psd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register -> move_src Types.sig0 **) +let reg_to_psd_argument__o__psd_argument_to_move_src__o__inject x0 = + psd_argument_move_src (Joint.psd_argument_from_reg x0) + +(** val dpi1__o__psd_argument_to_move_src__o__inject : + (Joint.psd_argument, 'a1) Types.dPair -> move_src Types.sig0 **) +let dpi1__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src x2.Types.dpi1 + +(** val eject__o__psd_argument_to_move_src__o__inject : + Joint.psd_argument Types.sig0 -> move_src Types.sig0 **) +let eject__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_move_src (Types.pi1 x2) + +(** val psd_argument_to_move_src__o__inject : + Joint.psd_argument -> move_src Types.sig0 **) +let psd_argument_to_move_src__o__inject x1 = + psd_argument_move_src x1 + +(** val byte_to_psd_argument__o__psd_argument_to_move_src : + BitVector.byte -> move_src **) +let byte_to_psd_argument__o__psd_argument_to_move_src x0 = + psd_argument_move_src (Joint.psd_argument_from_byte x0) + +(** val dpi1__o__byte_to_hdw_argument__o__psd_argument_to_move_src : + (BitVector.byte, 'a1) Types.dPair -> move_src **) +let dpi1__o__byte_to_hdw_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.dpi1__o__byte_to_hdw_argument x1) + +(** val dpi1__o__byte_to_psd_argument__o__psd_argument_to_move_src : + (BitVector.byte, 'a1) Types.dPair -> move_src **) +let dpi1__o__byte_to_psd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.dpi1__o__byte_to_psd_argument x1) + +(** val dpi1__o__reg_to_psd_argument__o__psd_argument_to_move_src : + (Registers.register, 'a1) Types.dPair -> move_src **) +let dpi1__o__reg_to_psd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.dpi1__o__reg_to_psd_argument x1) + +(** val eject__o__byte_to_hdw_argument__o__psd_argument_to_move_src : + BitVector.byte Types.sig0 -> move_src **) +let eject__o__byte_to_hdw_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.eject__o__byte_to_hdw_argument x1) + +(** val eject__o__byte_to_psd_argument__o__psd_argument_to_move_src : + BitVector.byte Types.sig0 -> move_src **) +let eject__o__byte_to_psd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.eject__o__byte_to_psd_argument x1) + +(** val eject__o__reg_to_psd_argument__o__psd_argument_to_move_src : + Registers.register Types.sig0 -> move_src **) +let eject__o__reg_to_psd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.eject__o__reg_to_psd_argument x1) + +(** val reg_to_psd_argument__o__psd_argument_to_move_src : + Registers.register -> move_src **) +let reg_to_psd_argument__o__psd_argument_to_move_src x0 = + psd_argument_move_src (Joint.psd_argument_from_reg x0) + +(** val dpi1__o__psd_argument_to_move_src : + (Joint.psd_argument, 'a1) Types.dPair -> move_src **) +let dpi1__o__psd_argument_to_move_src x1 = + psd_argument_move_src x1.Types.dpi1 + +(** val eject__o__psd_argument_to_move_src : + Joint.psd_argument Types.sig0 -> move_src **) +let eject__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Types.pi1 x1) + +type ertl_seq = +| Ertl_new_frame +| Ertl_del_frame +| Ertl_frame_size of Registers.register + +(** val ertl_seq_rect_Type4 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 **) +let rec ertl_seq_rect_Type4 h_ertl_new_frame h_ertl_del_frame h_ertl_frame_size = function +| Ertl_new_frame -> h_ertl_new_frame +| Ertl_del_frame -> h_ertl_del_frame +| Ertl_frame_size x_18564 -> h_ertl_frame_size x_18564 + +(** val ertl_seq_rect_Type5 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 **) +let rec ertl_seq_rect_Type5 h_ertl_new_frame h_ertl_del_frame h_ertl_frame_size = function +| Ertl_new_frame -> h_ertl_new_frame +| Ertl_del_frame -> h_ertl_del_frame +| Ertl_frame_size x_18569 -> h_ertl_frame_size x_18569 + +(** val ertl_seq_rect_Type3 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 **) +let rec ertl_seq_rect_Type3 h_ertl_new_frame h_ertl_del_frame h_ertl_frame_size = function +| Ertl_new_frame -> h_ertl_new_frame +| Ertl_del_frame -> h_ertl_del_frame +| Ertl_frame_size x_18574 -> h_ertl_frame_size x_18574 + +(** val ertl_seq_rect_Type2 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 **) +let rec ertl_seq_rect_Type2 h_ertl_new_frame h_ertl_del_frame h_ertl_frame_size = function +| Ertl_new_frame -> h_ertl_new_frame +| Ertl_del_frame -> h_ertl_del_frame +| Ertl_frame_size x_18579 -> h_ertl_frame_size x_18579 + +(** val ertl_seq_rect_Type1 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 **) +let rec ertl_seq_rect_Type1 h_ertl_new_frame h_ertl_del_frame h_ertl_frame_size = function +| Ertl_new_frame -> h_ertl_new_frame +| Ertl_del_frame -> h_ertl_del_frame +| Ertl_frame_size x_18584 -> h_ertl_frame_size x_18584 + +(** val ertl_seq_rect_Type0 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 **) +let rec ertl_seq_rect_Type0 h_ertl_new_frame h_ertl_del_frame h_ertl_frame_size = function +| Ertl_new_frame -> h_ertl_new_frame +| Ertl_del_frame -> h_ertl_del_frame +| Ertl_frame_size x_18589 -> h_ertl_frame_size x_18589 + +(** val ertl_seq_inv_rect_Type4 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> + 'a1) -> 'a1 **) +let ertl_seq_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = ertl_seq_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val ertl_seq_inv_rect_Type3 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> + 'a1) -> 'a1 **) +let ertl_seq_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = ertl_seq_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val ertl_seq_inv_rect_Type2 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> + 'a1) -> 'a1 **) +let ertl_seq_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = ertl_seq_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val ertl_seq_inv_rect_Type1 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> + 'a1) -> 'a1 **) +let ertl_seq_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = ertl_seq_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val ertl_seq_inv_rect_Type0 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> + 'a1) -> 'a1 **) +let ertl_seq_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = ertl_seq_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val ertl_seq_discr : ertl_seq -> ertl_seq -> __ **) +let ertl_seq_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Ertl_new_frame -> Obj.magic (fun _ dH -> dH) + | Ertl_del_frame -> Obj.magic (fun _ dH -> dH) + | Ertl_frame_size a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val ertl_seq_jmdiscr : ertl_seq -> ertl_seq -> __ **) +let ertl_seq_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Ertl_new_frame -> Obj.magic (fun _ dH -> dH) + | Ertl_del_frame -> Obj.magic (fun _ dH -> dH) + | Ertl_frame_size a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val eRTL_uns : Joint.unserialized_params **) +let eRTL_uns = + { Joint.ext_seq_labels = (fun x -> List.Nil); Joint.has_tailcalls = + Bool.False } + +(** val regs_from_move_dst : move_dst -> Registers.register List.list **) +let regs_from_move_dst = function +| PSD r -> List.Cons (r, List.Nil) +| HDW x -> List.Nil + +(** val regs_from_move_src : move_src -> Registers.register List.list **) +let regs_from_move_src = function +| Joint.Reg r -> + (match r with + | PSD r1 -> List.Cons (r1, List.Nil) + | HDW x -> List.Nil) +| Joint.Imm x -> List.Nil + +(** val ertl_ext_seq_regs : ertl_seq -> Registers.register List.list **) +let ertl_ext_seq_regs = function +| Ertl_new_frame -> List.Nil +| Ertl_del_frame -> List.Nil +| Ertl_frame_size r -> List.Cons (r, List.Nil) + +(** val eRTL_functs : Joint.get_pseudo_reg_functs **) +let eRTL_functs = + { Joint.acc_a_regs = (fun r -> List.Cons ((Obj.magic r), List.Nil)); + Joint.acc_b_regs = (fun r -> List.Cons ((Obj.magic r), List.Nil)); + Joint.acc_a_args = (fun arg -> + match Obj.magic arg with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.acc_b_args = (fun arg -> + match Obj.magic arg with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.dpl_regs = (fun r -> List.Cons + ((Obj.magic r), List.Nil)); Joint.dph_regs = (fun r -> List.Cons + ((Obj.magic r), List.Nil)); Joint.dpl_args = (fun arg -> + match Obj.magic arg with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.dph_args = (fun arg -> + match Obj.magic arg with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.snd_args = (fun arg -> + match Obj.magic arg with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.pair_move_regs = (fun x -> + List.append (regs_from_move_dst (Obj.magic x).Types.fst) + (regs_from_move_src (Obj.magic x).Types.snd)); Joint.f_call_args = + (fun x -> List.Nil); Joint.f_call_dest = (fun x -> List.Nil); + Joint.ext_seq_regs = (Obj.magic ertl_ext_seq_regs); Joint.params_regs = + (fun x -> List.Nil) } + +(** val eRTL : Joint.graph_params **) +let eRTL = + { Joint.u_pars = eRTL_uns; Joint.functs = eRTL_functs } + +type ertl_program = Joint.joint_program + +(** val dpi1__o__reg_to_ertl_snd_argument__o__inject : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 **) +let dpi1__o__reg_to_ertl_snd_argument__o__inject x2 = + Joint.psd_argument_from_reg x2.Types.dpi1 + +(** val dpi1__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + (Registers.register, 'a1) Types.dPair -> move_src Types.sig0 **) +let dpi1__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_to_move_src__o__inject + (Joint.psd_argument_from_reg x2.Types.dpi1) + +(** val dpi1__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src : + (Registers.register, 'a1) Types.dPair -> move_src **) +let dpi1__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.psd_argument_from_reg x1.Types.dpi1) + +(** val eject__o__reg_to_ertl_snd_argument__o__inject : + Registers.register Types.sig0 -> Joint.psd_argument Types.sig0 **) +let eject__o__reg_to_ertl_snd_argument__o__inject x2 = + Joint.psd_argument_from_reg (Types.pi1 x2) + +(** val eject__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register Types.sig0 -> move_src Types.sig0 **) +let eject__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_to_move_src__o__inject + (Joint.psd_argument_from_reg (Types.pi1 x2)) + +(** val eject__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src : + Registers.register Types.sig0 -> move_src **) +let eject__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.psd_argument_from_reg (Types.pi1 x1)) + +(** val reg_to_ertl_snd_argument__o__psd_argument_to_move_src : + Registers.register -> move_src **) +let reg_to_ertl_snd_argument__o__psd_argument_to_move_src x0 = + psd_argument_move_src (Joint.psd_argument_from_reg x0) + +(** val reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register -> move_src Types.sig0 **) +let reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject x1 = + psd_argument_to_move_src__o__inject (Joint.psd_argument_from_reg x1) + +(** val reg_to_ertl_snd_argument__o__inject : + Registers.register -> Joint.psd_argument Types.sig0 **) +let reg_to_ertl_snd_argument__o__inject x1 = + Joint.psd_argument_from_reg x1 + +(** val dpi1__o__reg_to_ertl_snd_argument : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument **) +let dpi1__o__reg_to_ertl_snd_argument x1 = + Joint.psd_argument_from_reg x1.Types.dpi1 + +(** val eject__o__reg_to_ertl_snd_argument : + Registers.register Types.sig0 -> Joint.psd_argument **) +let eject__o__reg_to_ertl_snd_argument x1 = + Joint.psd_argument_from_reg (Types.pi1 x1) + +(** val dpi1__o__byte_to_ertl_snd_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 **) +let dpi1__o__byte_to_ertl_snd_argument__o__inject x2 = + Joint.psd_argument_from_byte x2.Types.dpi1 + +(** val dpi1__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + (BitVector.byte, 'a1) Types.dPair -> move_src Types.sig0 **) +let dpi1__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_to_move_src__o__inject + (Joint.psd_argument_from_byte x2.Types.dpi1) + +(** val dpi1__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src : + (BitVector.byte, 'a1) Types.dPair -> move_src **) +let dpi1__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.psd_argument_from_byte x1.Types.dpi1) + +(** val eject__o__byte_to_ertl_snd_argument__o__inject : + BitVector.byte Types.sig0 -> Joint.psd_argument Types.sig0 **) +let eject__o__byte_to_ertl_snd_argument__o__inject x2 = + Joint.psd_argument_from_byte (Types.pi1 x2) + +(** val eject__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte Types.sig0 -> move_src Types.sig0 **) +let eject__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject x2 = + psd_argument_to_move_src__o__inject + (Joint.psd_argument_from_byte (Types.pi1 x2)) + +(** val eject__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src : + BitVector.byte Types.sig0 -> move_src **) +let eject__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src x1 = + psd_argument_move_src (Joint.psd_argument_from_byte (Types.pi1 x1)) + +(** val byte_to_ertl_snd_argument__o__psd_argument_to_move_src : + BitVector.byte -> move_src **) +let byte_to_ertl_snd_argument__o__psd_argument_to_move_src x0 = + psd_argument_move_src (Joint.psd_argument_from_byte x0) + +(** val byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte -> move_src Types.sig0 **) +let byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject x1 = + psd_argument_to_move_src__o__inject (Joint.psd_argument_from_byte x1) + +(** val byte_to_ertl_snd_argument__o__inject : + BitVector.byte -> Joint.psd_argument Types.sig0 **) +let byte_to_ertl_snd_argument__o__inject x1 = + Joint.psd_argument_from_byte x1 + +(** val dpi1__o__byte_to_ertl_snd_argument : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument **) +let dpi1__o__byte_to_ertl_snd_argument x1 = + Joint.psd_argument_from_byte x1.Types.dpi1 + +(** val eject__o__byte_to_ertl_snd_argument : + BitVector.byte Types.sig0 -> Joint.psd_argument **) +let eject__o__byte_to_ertl_snd_argument x1 = + Joint.psd_argument_from_byte (Types.pi1 x1) + +(** val ertl_seq_joint : AST.ident List.list -> __ -> Joint.joint_seq **) +let ertl_seq_joint = + Obj.magic (fun _ x -> Joint.Extension_seq x) + +(** val dpi1__o__ertl_seq_to_joint_seq__o__inject : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_seq + Types.sig0 **) +let dpi1__o__ertl_seq_to_joint_seq__o__inject x1 x2 = + ertl_seq_joint x1 x2.Types.dpi1 + +(** val dpi1__o__ertl_seq_to_joint_seq__o__seq_to_step__o__inject : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_step + Types.sig0 **) +let dpi1__o__ertl_seq_to_joint_seq__o__seq_to_step__o__inject x1 x2 = + Joint.seq_to_step__o__inject + (Joint.gp_to_p__o__stmt_pars__o__uns_pars__o__u_pars eRTL) x1 + (ertl_seq_joint x1 x2.Types.dpi1) + +(** val dpi1__o__ertl_seq_to_joint_seq__o__seq_to_step : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_step **) +let dpi1__o__ertl_seq_to_joint_seq__o__seq_to_step x1 x2 = + Joint.Step_seq (ertl_seq_joint x1 x2.Types.dpi1) + +(** val eject__o__ertl_seq_to_joint_seq__o__inject : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_seq Types.sig0 **) +let eject__o__ertl_seq_to_joint_seq__o__inject x1 x2 = + ertl_seq_joint x1 (Types.pi1 x2) + +(** val eject__o__ertl_seq_to_joint_seq__o__seq_to_step__o__inject : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_step Types.sig0 **) +let eject__o__ertl_seq_to_joint_seq__o__seq_to_step__o__inject x1 x2 = + Joint.seq_to_step__o__inject + (Joint.gp_to_p__o__stmt_pars__o__uns_pars__o__u_pars eRTL) x1 + (ertl_seq_joint x1 (Types.pi1 x2)) + +(** val eject__o__ertl_seq_to_joint_seq__o__seq_to_step : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_step **) +let eject__o__ertl_seq_to_joint_seq__o__seq_to_step x1 x2 = + Joint.Step_seq (ertl_seq_joint x1 (Types.pi1 x2)) + +(** val ertl_seq_to_joint_seq__o__seq_to_step : + AST.ident List.list -> __ -> Joint.joint_step **) +let ertl_seq_to_joint_seq__o__seq_to_step x0 x1 = + Joint.Step_seq (ertl_seq_joint x0 x1) + +(** val ertl_seq_to_joint_seq__o__seq_to_step__o__inject : + AST.ident List.list -> __ -> Joint.joint_step Types.sig0 **) +let ertl_seq_to_joint_seq__o__seq_to_step__o__inject x0 x1 = + Joint.seq_to_step__o__inject + (Joint.gp_to_p__o__stmt_pars__o__uns_pars__o__u_pars eRTL) x0 + (ertl_seq_joint x0 x1) + +(** val ertl_seq_to_joint_seq__o__inject : + AST.ident List.list -> __ -> Joint.joint_seq Types.sig0 **) +let ertl_seq_to_joint_seq__o__inject x0 x1 = + ertl_seq_joint x0 x1 + +(** val dpi1__o__ertl_seq_to_joint_seq : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_seq **) +let dpi1__o__ertl_seq_to_joint_seq x1 x2 = + ertl_seq_joint x1 x2.Types.dpi1 + +(** val eject__o__ertl_seq_to_joint_seq : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_seq **) +let eject__o__ertl_seq_to_joint_seq x1 x2 = + ertl_seq_joint x1 (Types.pi1 x2) + +(** val eRTL_premain : + ertl_program -> Joint.joint_closed_internal_function **) +let eRTL_premain p = + let l1 = Positive.One in + let l2 = Positive.P0 Positive.One in + let l3 = Positive.P1 Positive.One in + let res = { Joint.joint_if_luniverse = (Positive.P0 (Positive.P0 + Positive.One)); Joint.joint_if_runiverse = Positive.One; + Joint.joint_if_result = (Obj.magic Types.It); Joint.joint_if_params = + (Obj.magic (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))); + Joint.joint_if_stacksize = Nat.O; Joint.joint_if_local_stacksize = Nat.O; + Joint.joint_if_code = + (Obj.magic (Identifiers.empty_map PreIdentifiers.LabelTag)); + Joint.joint_if_entry = (Obj.magic l1) } + in + let res0 = + Joint.add_graph eRTL + (Joint.prog_names (Joint.graph_params_to_params eRTL) p) l1 + (Joint.Sequential ((Joint.COST_LABEL p.Joint.init_cost_label), + (Obj.magic l2))) res + in + let res1 = + Joint.add_graph eRTL + (Joint.prog_names (Joint.graph_params_to_params eRTL) p) l2 + (Joint.Sequential ((Joint.CALL ((Types.Inl + p.Joint.joint_prog.AST.prog_main), (Obj.magic Nat.O), + (Obj.magic Types.It))), (Obj.magic l3))) res0 + in + let res2 = + Joint.add_graph eRTL + (Joint.prog_names (Joint.graph_params_to_params eRTL) p) l3 + (Joint.Final (Joint.GOTO l3)) res1 + in + res2 + diff --git a/extracted/eRTL.mli b/extracted/eRTL.mli new file mode 100644 index 0000000..1ac241f --- /dev/null +++ b/extracted/eRTL.mli @@ -0,0 +1,411 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type move_dst = +| PSD of Registers.register +| HDW of I8051.register + +val move_dst_rect_Type4 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 + +val move_dst_rect_Type5 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 + +val move_dst_rect_Type3 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 + +val move_dst_rect_Type2 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 + +val move_dst_rect_Type1 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 + +val move_dst_rect_Type0 : + (Registers.register -> 'a1) -> (I8051.register -> 'a1) -> move_dst -> 'a1 + +val move_dst_inv_rect_Type4 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 + +val move_dst_inv_rect_Type3 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 + +val move_dst_inv_rect_Type2 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 + +val move_dst_inv_rect_Type1 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 + +val move_dst_inv_rect_Type0 : + move_dst -> (Registers.register -> __ -> 'a1) -> (I8051.register -> __ -> + 'a1) -> 'a1 + +val move_dst_discr : move_dst -> move_dst -> __ + +val move_dst_jmdiscr : move_dst -> move_dst -> __ + +type move_src = move_dst Joint.argument + +val move_src_from_dst : move_dst -> move_src + +val dpi1__o__move_dst_to_src__o__inject : + (move_dst, 'a1) Types.dPair -> move_src Types.sig0 + +val eject__o__move_dst_to_src__o__inject : + move_dst Types.sig0 -> move_src Types.sig0 + +val move_dst_to_src__o__inject : move_dst -> move_src Types.sig0 + +val dpi1__o__move_dst_to_src : (move_dst, 'a1) Types.dPair -> move_src + +val eject__o__move_dst_to_src : move_dst Types.sig0 -> move_src + +val psd_argument_move_src : Joint.psd_argument -> move_src + +val byte_to_psd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte -> move_src Types.sig0 + +val dpi1__o__byte_to_hdw_argument__o__psd_argument_to_move_src__o__inject : + (BitVector.byte, 'a1) Types.dPair -> move_src Types.sig0 + +val dpi1__o__byte_to_psd_argument__o__psd_argument_to_move_src__o__inject : + (BitVector.byte, 'a1) Types.dPair -> move_src Types.sig0 + +val dpi1__o__reg_to_psd_argument__o__psd_argument_to_move_src__o__inject : + (Registers.register, 'a1) Types.dPair -> move_src Types.sig0 + +val eject__o__byte_to_hdw_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte Types.sig0 -> move_src Types.sig0 + +val eject__o__byte_to_psd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte Types.sig0 -> move_src Types.sig0 + +val eject__o__reg_to_psd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register Types.sig0 -> move_src Types.sig0 + +val reg_to_psd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register -> move_src Types.sig0 + +val dpi1__o__psd_argument_to_move_src__o__inject : + (Joint.psd_argument, 'a1) Types.dPair -> move_src Types.sig0 + +val eject__o__psd_argument_to_move_src__o__inject : + Joint.psd_argument Types.sig0 -> move_src Types.sig0 + +val psd_argument_to_move_src__o__inject : + Joint.psd_argument -> move_src Types.sig0 + +val byte_to_psd_argument__o__psd_argument_to_move_src : + BitVector.byte -> move_src + +val dpi1__o__byte_to_hdw_argument__o__psd_argument_to_move_src : + (BitVector.byte, 'a1) Types.dPair -> move_src + +val dpi1__o__byte_to_psd_argument__o__psd_argument_to_move_src : + (BitVector.byte, 'a1) Types.dPair -> move_src + +val dpi1__o__reg_to_psd_argument__o__psd_argument_to_move_src : + (Registers.register, 'a1) Types.dPair -> move_src + +val eject__o__byte_to_hdw_argument__o__psd_argument_to_move_src : + BitVector.byte Types.sig0 -> move_src + +val eject__o__byte_to_psd_argument__o__psd_argument_to_move_src : + BitVector.byte Types.sig0 -> move_src + +val eject__o__reg_to_psd_argument__o__psd_argument_to_move_src : + Registers.register Types.sig0 -> move_src + +val reg_to_psd_argument__o__psd_argument_to_move_src : + Registers.register -> move_src + +val dpi1__o__psd_argument_to_move_src : + (Joint.psd_argument, 'a1) Types.dPair -> move_src + +val eject__o__psd_argument_to_move_src : + Joint.psd_argument Types.sig0 -> move_src + +type ertl_seq = +| Ertl_new_frame +| Ertl_del_frame +| Ertl_frame_size of Registers.register + +val ertl_seq_rect_Type4 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 + +val ertl_seq_rect_Type5 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 + +val ertl_seq_rect_Type3 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 + +val ertl_seq_rect_Type2 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 + +val ertl_seq_rect_Type1 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 + +val ertl_seq_rect_Type0 : + 'a1 -> 'a1 -> (Registers.register -> 'a1) -> ertl_seq -> 'a1 + +val ertl_seq_inv_rect_Type4 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> 'a1) + -> 'a1 + +val ertl_seq_inv_rect_Type3 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> 'a1) + -> 'a1 + +val ertl_seq_inv_rect_Type2 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> 'a1) + -> 'a1 + +val ertl_seq_inv_rect_Type1 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> 'a1) + -> 'a1 + +val ertl_seq_inv_rect_Type0 : + ertl_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Registers.register -> __ -> 'a1) + -> 'a1 + +val ertl_seq_discr : ertl_seq -> ertl_seq -> __ + +val ertl_seq_jmdiscr : ertl_seq -> ertl_seq -> __ + +val eRTL_uns : Joint.unserialized_params + +val regs_from_move_dst : move_dst -> Registers.register List.list + +val regs_from_move_src : move_src -> Registers.register List.list + +val ertl_ext_seq_regs : ertl_seq -> Registers.register List.list + +val eRTL_functs : Joint.get_pseudo_reg_functs + +val eRTL : Joint.graph_params + +type ertl_program = Joint.joint_program + +val dpi1__o__reg_to_ertl_snd_argument__o__inject : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 + +val dpi1__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + (Registers.register, 'a1) Types.dPair -> move_src Types.sig0 + +val dpi1__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src : + (Registers.register, 'a1) Types.dPair -> move_src + +val eject__o__reg_to_ertl_snd_argument__o__inject : + Registers.register Types.sig0 -> Joint.psd_argument Types.sig0 + +val eject__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register Types.sig0 -> move_src Types.sig0 + +val eject__o__reg_to_ertl_snd_argument__o__psd_argument_to_move_src : + Registers.register Types.sig0 -> move_src + +val reg_to_ertl_snd_argument__o__psd_argument_to_move_src : + Registers.register -> move_src + +val reg_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + Registers.register -> move_src Types.sig0 + +val reg_to_ertl_snd_argument__o__inject : + Registers.register -> Joint.psd_argument Types.sig0 + +val dpi1__o__reg_to_ertl_snd_argument : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument + +val eject__o__reg_to_ertl_snd_argument : + Registers.register Types.sig0 -> Joint.psd_argument + +val dpi1__o__byte_to_ertl_snd_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 + +val dpi1__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + (BitVector.byte, 'a1) Types.dPair -> move_src Types.sig0 + +val dpi1__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src : + (BitVector.byte, 'a1) Types.dPair -> move_src + +val eject__o__byte_to_ertl_snd_argument__o__inject : + BitVector.byte Types.sig0 -> Joint.psd_argument Types.sig0 + +val eject__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte Types.sig0 -> move_src Types.sig0 + +val eject__o__byte_to_ertl_snd_argument__o__psd_argument_to_move_src : + BitVector.byte Types.sig0 -> move_src + +val byte_to_ertl_snd_argument__o__psd_argument_to_move_src : + BitVector.byte -> move_src + +val byte_to_ertl_snd_argument__o__psd_argument_to_move_src__o__inject : + BitVector.byte -> move_src Types.sig0 + +val byte_to_ertl_snd_argument__o__inject : + BitVector.byte -> Joint.psd_argument Types.sig0 + +val dpi1__o__byte_to_ertl_snd_argument : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument + +val eject__o__byte_to_ertl_snd_argument : + BitVector.byte Types.sig0 -> Joint.psd_argument + +val ertl_seq_joint : AST.ident List.list -> __ -> Joint.joint_seq + +val dpi1__o__ertl_seq_to_joint_seq__o__inject : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_seq Types.sig0 + +val dpi1__o__ertl_seq_to_joint_seq__o__seq_to_step__o__inject : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_step Types.sig0 + +val dpi1__o__ertl_seq_to_joint_seq__o__seq_to_step : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_step + +val eject__o__ertl_seq_to_joint_seq__o__inject : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_seq Types.sig0 + +val eject__o__ertl_seq_to_joint_seq__o__seq_to_step__o__inject : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_step Types.sig0 + +val eject__o__ertl_seq_to_joint_seq__o__seq_to_step : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_step + +val ertl_seq_to_joint_seq__o__seq_to_step : + AST.ident List.list -> __ -> Joint.joint_step + +val ertl_seq_to_joint_seq__o__seq_to_step__o__inject : + AST.ident List.list -> __ -> Joint.joint_step Types.sig0 + +val ertl_seq_to_joint_seq__o__inject : + AST.ident List.list -> __ -> Joint.joint_seq Types.sig0 + +val dpi1__o__ertl_seq_to_joint_seq : + AST.ident List.list -> (__, 'a1) Types.dPair -> Joint.joint_seq + +val eject__o__ertl_seq_to_joint_seq : + AST.ident List.list -> __ Types.sig0 -> Joint.joint_seq + +val eRTL_premain : ertl_program -> Joint.joint_closed_internal_function + diff --git a/extracted/eRTLToLTL.ml b/extracted/eRTLToLTL.ml new file mode 100644 index 0000000..9a5425c --- /dev/null +++ b/extracted/eRTLToLTL.ml @@ -0,0 +1,985 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open LTL + +open Fixpoints + +open Set_adt + +open ERTL + +open Liveness + +open Interference + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +(** val dpi1__o__Reg_to_dec__o__inject : + (I8051.register, 'a1) Types.dPair -> Interference.decision Types.sig0 **) +let dpi1__o__Reg_to_dec__o__inject x2 = + Interference.Decision_colour x2.Types.dpi1 + +(** val eject__o__Reg_to_dec__o__inject : + I8051.register Types.sig0 -> Interference.decision Types.sig0 **) +let eject__o__Reg_to_dec__o__inject x2 = + Interference.Decision_colour (Types.pi1 x2) + +(** val reg_to_dec__o__inject : + I8051.register -> Interference.decision Types.sig0 **) +let reg_to_dec__o__inject x1 = + Interference.Decision_colour x1 + +(** val dpi1__o__Reg_to_dec : + (I8051.register, 'a1) Types.dPair -> Interference.decision **) +let dpi1__o__Reg_to_dec x1 = + Interference.Decision_colour x1.Types.dpi1 + +(** val eject__o__Reg_to_dec : + I8051.register Types.sig0 -> Interference.decision **) +let eject__o__Reg_to_dec x1 = + Interference.Decision_colour (Types.pi1 x1) + +type arg_decision = +| Arg_decision_colour of I8051.register +| Arg_decision_spill of Nat.nat +| Arg_decision_imm of BitVector.byte + +(** val arg_decision_rect_Type4 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 **) +let rec arg_decision_rect_Type4 h_arg_decision_colour h_arg_decision_spill h_arg_decision_imm = function +| Arg_decision_colour x_19045 -> h_arg_decision_colour x_19045 +| Arg_decision_spill x_19046 -> h_arg_decision_spill x_19046 +| Arg_decision_imm x_19047 -> h_arg_decision_imm x_19047 + +(** val arg_decision_rect_Type5 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 **) +let rec arg_decision_rect_Type5 h_arg_decision_colour h_arg_decision_spill h_arg_decision_imm = function +| Arg_decision_colour x_19052 -> h_arg_decision_colour x_19052 +| Arg_decision_spill x_19053 -> h_arg_decision_spill x_19053 +| Arg_decision_imm x_19054 -> h_arg_decision_imm x_19054 + +(** val arg_decision_rect_Type3 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 **) +let rec arg_decision_rect_Type3 h_arg_decision_colour h_arg_decision_spill h_arg_decision_imm = function +| Arg_decision_colour x_19059 -> h_arg_decision_colour x_19059 +| Arg_decision_spill x_19060 -> h_arg_decision_spill x_19060 +| Arg_decision_imm x_19061 -> h_arg_decision_imm x_19061 + +(** val arg_decision_rect_Type2 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 **) +let rec arg_decision_rect_Type2 h_arg_decision_colour h_arg_decision_spill h_arg_decision_imm = function +| Arg_decision_colour x_19066 -> h_arg_decision_colour x_19066 +| Arg_decision_spill x_19067 -> h_arg_decision_spill x_19067 +| Arg_decision_imm x_19068 -> h_arg_decision_imm x_19068 + +(** val arg_decision_rect_Type1 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 **) +let rec arg_decision_rect_Type1 h_arg_decision_colour h_arg_decision_spill h_arg_decision_imm = function +| Arg_decision_colour x_19073 -> h_arg_decision_colour x_19073 +| Arg_decision_spill x_19074 -> h_arg_decision_spill x_19074 +| Arg_decision_imm x_19075 -> h_arg_decision_imm x_19075 + +(** val arg_decision_rect_Type0 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 **) +let rec arg_decision_rect_Type0 h_arg_decision_colour h_arg_decision_spill h_arg_decision_imm = function +| Arg_decision_colour x_19080 -> h_arg_decision_colour x_19080 +| Arg_decision_spill x_19081 -> h_arg_decision_spill x_19081 +| Arg_decision_imm x_19082 -> h_arg_decision_imm x_19082 + +(** val arg_decision_inv_rect_Type4 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) + -> (BitVector.byte -> __ -> 'a1) -> 'a1 **) +let arg_decision_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = arg_decision_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val arg_decision_inv_rect_Type3 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) + -> (BitVector.byte -> __ -> 'a1) -> 'a1 **) +let arg_decision_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = arg_decision_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val arg_decision_inv_rect_Type2 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) + -> (BitVector.byte -> __ -> 'a1) -> 'a1 **) +let arg_decision_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = arg_decision_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val arg_decision_inv_rect_Type1 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) + -> (BitVector.byte -> __ -> 'a1) -> 'a1 **) +let arg_decision_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = arg_decision_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val arg_decision_inv_rect_Type0 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) + -> (BitVector.byte -> __ -> 'a1) -> 'a1 **) +let arg_decision_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = arg_decision_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val arg_decision_discr : arg_decision -> arg_decision -> __ **) +let arg_decision_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Arg_decision_colour a0 -> Obj.magic (fun _ dH -> dH __) + | Arg_decision_spill a0 -> Obj.magic (fun _ dH -> dH __) + | Arg_decision_imm a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val arg_decision_jmdiscr : arg_decision -> arg_decision -> __ **) +let arg_decision_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Arg_decision_colour a0 -> Obj.magic (fun _ dH -> dH __) + | Arg_decision_spill a0 -> Obj.magic (fun _ dH -> dH __) + | Arg_decision_imm a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val dpi1__o__Reg_to_arg_dec__o__inject : + (I8051.register, 'a1) Types.dPair -> arg_decision Types.sig0 **) +let dpi1__o__Reg_to_arg_dec__o__inject x2 = + Arg_decision_colour x2.Types.dpi1 + +(** val eject__o__Reg_to_arg_dec__o__inject : + I8051.register Types.sig0 -> arg_decision Types.sig0 **) +let eject__o__Reg_to_arg_dec__o__inject x2 = + Arg_decision_colour (Types.pi1 x2) + +(** val reg_to_arg_dec__o__inject : + I8051.register -> arg_decision Types.sig0 **) +let reg_to_arg_dec__o__inject x1 = + Arg_decision_colour x1 + +(** val dpi1__o__Reg_to_arg_dec : + (I8051.register, 'a1) Types.dPair -> arg_decision **) +let dpi1__o__Reg_to_arg_dec x1 = + Arg_decision_colour x1.Types.dpi1 + +(** val eject__o__Reg_to_arg_dec : + I8051.register Types.sig0 -> arg_decision **) +let eject__o__Reg_to_arg_dec x1 = + Arg_decision_colour (Types.pi1 x1) + +(** val preserve_carry_bit : + AST.ident List.list -> Bool.bool -> Joint.joint_seq List.list -> + Joint.joint_seq List.list **) +let preserve_carry_bit globals do_it steps = + match do_it with + | Bool.True -> + List.Cons ((Joint.Extension_seq (Obj.magic Joint_LTL_LIN.SAVE_CARRY)), + (List.append steps (List.Cons ((Joint.Extension_seq + (Obj.magic Joint_LTL_LIN.RESTORE_CARRY)), List.Nil)))) + | Bool.False -> steps + +(** val a : Types.unit0 **) +let a = + Types.It + +(** val dpi1__o__beval_of_byte__o__inject : + (BitVector.byte, 'a1) Types.dPair -> ByteValues.beval Types.sig0 **) +let dpi1__o__beval_of_byte__o__inject x2 = + ByteValues.BVByte x2.Types.dpi1 + +(** val eject__o__beval_of_byte__o__inject : + BitVector.byte Types.sig0 -> ByteValues.beval Types.sig0 **) +let eject__o__beval_of_byte__o__inject x2 = + ByteValues.BVByte (Types.pi1 x2) + +(** val beval_of_byte__o__inject : + BitVector.byte -> ByteValues.beval Types.sig0 **) +let beval_of_byte__o__inject x1 = + ByteValues.BVByte x1 + +(** val dpi1__o__beval_of_byte : + (BitVector.byte, 'a1) Types.dPair -> ByteValues.beval **) +let dpi1__o__beval_of_byte x1 = + ByteValues.BVByte x1.Types.dpi1 + +(** val eject__o__beval_of_byte : + BitVector.byte Types.sig0 -> ByteValues.beval **) +let eject__o__beval_of_byte x1 = + ByteValues.BVByte (Types.pi1 x1) + +(** val set_dp_by_offset : + AST.ident List.list -> Nat.nat -> Joint.joint_seq List.list **) +let set_dp_by_offset globals off = + List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.Int_to_acc (a, (Joint.byte_of_nat off))))), + (List.Cons ((Joint.OP2 (BackEndOps.Add, (Obj.magic a), (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_reg I8051.registerSPL)))), (List.Cons + ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (I8051.RegisterDPL, a)))), (List.Cons + ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.Int_to_acc (a, Joint.zero_byte)))), (List.Cons + ((Joint.OP2 (BackEndOps.Addc, (Obj.magic a), (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_reg I8051.registerSPH)))), (List.Cons + ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (I8051.RegisterDPH, a)))), + List.Nil))))))))))) + +(** val get_stack : + AST.ident List.list -> Nat.nat -> I8051.register -> Nat.nat -> + Joint.joint_seq List.list **) +let get_stack globals localss r off = + let off0 = Nat.plus localss off in + List.append (set_dp_by_offset globals off0) + (List.append (List.Cons ((Joint.LOAD ((Obj.magic a), + (Obj.magic Types.It), (Obj.magic Types.It))), List.Nil)) + (match I8051.eq_Register r I8051.RegisterA with + | Bool.True -> List.Nil + | Bool.False -> + List.Cons ((Joint.MOVE (Obj.magic (Joint_LTL_LIN.From_acc (r, a)))), + List.Nil))) + +(** val set_stack_not_a : + AST.ident List.list -> Nat.nat -> Nat.nat -> I8051.register -> + Joint.joint_seq List.list **) +let set_stack_not_a globals localss off r = + let off0 = Nat.plus localss off in + List.append (set_dp_by_offset globals off0) (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.To_acc (a, r)))), (List.Cons ((Joint.STORE + ((Obj.magic Types.It), (Obj.magic Types.It), (Obj.magic a))), + List.Nil)))) + +(** val set_stack_a : + AST.ident List.list -> Nat.nat -> Nat.nat -> Joint.joint_seq List.list **) +let set_stack_a globals localss off = + List.append (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (I8051.registerST1, a)))), List.Nil)) + (set_stack_not_a globals localss off I8051.registerST1) + +(** val set_stack : + AST.ident List.list -> Nat.nat -> Nat.nat -> I8051.register -> + Joint.joint_seq List.list **) +let set_stack globals localss off r = + match I8051.eq_Register r I8051.RegisterA with + | Bool.True -> set_stack_a globals localss off + | Bool.False -> set_stack_not_a globals localss off r + +(** val set_stack_int : + AST.ident List.list -> Nat.nat -> Nat.nat -> BitVector.byte -> + Joint.joint_seq List.list **) +let set_stack_int globals localss off int = + let off0 = Nat.plus localss off in + List.append (set_dp_by_offset globals off0) (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.Int_to_acc (a, int)))), (List.Cons + ((Joint.STORE ((Obj.magic Types.It), (Obj.magic Types.It), + (Obj.magic a))), List.Nil)))) + +(** val move : + AST.ident List.list -> Nat.nat -> Bool.bool -> Interference.decision -> + arg_decision -> Joint.joint_seq List.list **) +let move globals localss carry_lives_after dst src = + match dst with + | Interference.Decision_spill dsto -> + (match src with + | Arg_decision_colour srcr -> + preserve_carry_bit globals carry_lives_after + (set_stack globals localss dsto srcr) + | Arg_decision_spill srco -> + (match Nat.eqb srco dsto with + | Bool.True -> List.Nil + | Bool.False -> + preserve_carry_bit globals carry_lives_after + (List.append (get_stack globals localss I8051.RegisterA srco) + (set_stack globals localss dsto I8051.RegisterA))) + | Arg_decision_imm int -> + preserve_carry_bit globals carry_lives_after + (set_stack_int globals localss dsto int)) + | Interference.Decision_colour dstr -> + (match src with + | Arg_decision_colour srcr -> + (match I8051.eq_Register dstr srcr with + | Bool.True -> List.Nil + | Bool.False -> + (match I8051.eq_Register dstr I8051.RegisterA with + | Bool.True -> + List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.To_acc (a, srcr)))), List.Nil) + | Bool.False -> + (match I8051.eq_Register srcr I8051.RegisterA with + | Bool.True -> + List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (dstr, a)))), List.Nil) + | Bool.False -> + List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.To_acc (a, srcr)))), (List.Cons + ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (dstr, a)))), + List.Nil)))))) + | Arg_decision_spill srco -> + preserve_carry_bit globals carry_lives_after + (get_stack globals localss dstr srco) + | Arg_decision_imm int -> + List.append (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.Int_to_acc (a, int)))), List.Nil)) + (match I8051.eq_Register dstr I8051.RegisterA with + | Bool.True -> List.Nil + | Bool.False -> + List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (dstr, a)))), List.Nil))) + +(** val arg_is_spilled : arg_decision -> Bool.bool **) +let arg_is_spilled = function +| Arg_decision_colour x0 -> Bool.False +| Arg_decision_spill x0 -> Bool.True +| Arg_decision_imm x0 -> Bool.False + +(** val is_spilled : Interference.decision -> Bool.bool **) +let is_spilled = function +| Interference.Decision_spill x0 -> Bool.True +| Interference.Decision_colour x0 -> Bool.False + +(** val newframe : + AST.ident List.list -> Nat.nat -> Joint.joint_seq List.list **) +let newframe globals stack_sz = + List.Cons (Joint.CLEAR_CARRY, (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.To_acc (a, I8051.registerSPL)))), (List.Cons + ((Joint.OP2 (BackEndOps.Sub, (Obj.magic a), (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_byte (Joint.byte_of_nat stack_sz))))), + (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (I8051.registerSPL, a)))), (List.Cons + ((Joint.MOVE (Obj.magic (Joint_LTL_LIN.To_acc (a, I8051.registerSPH)))), + (List.Cons ((Joint.OP2 (BackEndOps.Sub, (Obj.magic a), (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_byte Joint.zero_byte)))), (List.Cons + ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (I8051.registerSPH, a)))), + List.Nil))))))))))))) + +(** val delframe : + AST.ident List.list -> Nat.nat -> Joint.joint_seq List.list **) +let delframe globals stack_sz = + List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.To_acc (a, I8051.registerSPL)))), (List.Cons + ((Joint.OP2 (BackEndOps.Add, (Obj.magic a), (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_byte (Joint.byte_of_nat stack_sz))))), + (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (I8051.registerSPL, a)))), (List.Cons + ((Joint.MOVE (Obj.magic (Joint_LTL_LIN.To_acc (a, I8051.registerSPH)))), + (List.Cons ((Joint.OP2 (BackEndOps.Addc, (Obj.magic a), (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_byte Joint.zero_byte)))), (List.Cons + ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.From_acc (I8051.registerSPH, a)))), + List.Nil))))))))))) + +(** val commutative : BackEndOps.op2 -> Bool.bool **) +let commutative = function +| BackEndOps.Add -> Bool.True +| BackEndOps.Addc -> Bool.True +| BackEndOps.Sub -> Bool.False +| BackEndOps.And -> Bool.True +| BackEndOps.Or -> Bool.True +| BackEndOps.Xor -> Bool.True + +(** val uses_carry : BackEndOps.op2 -> Bool.bool **) +let uses_carry = function +| BackEndOps.Add -> Bool.False +| BackEndOps.Addc -> Bool.True +| BackEndOps.Sub -> Bool.True +| BackEndOps.And -> Bool.False +| BackEndOps.Or -> Bool.False +| BackEndOps.Xor -> Bool.False + +(** val sets_carry : BackEndOps.op2 -> Bool.bool **) +let sets_carry = function +| BackEndOps.Add -> Bool.True +| BackEndOps.Addc -> Bool.True +| BackEndOps.Sub -> Bool.True +| BackEndOps.And -> Bool.False +| BackEndOps.Or -> Bool.False +| BackEndOps.Xor -> Bool.False + +(** val translate_op2 : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.op2 -> + Interference.decision -> arg_decision -> arg_decision -> Joint.joint_seq + List.list **) +let translate_op2 globals localss carry_lives_after op dst arg1 arg2 = + List.append + (preserve_carry_bit globals + (Bool.andb (uses_carry op) + (Bool.orb (arg_is_spilled arg1) (arg_is_spilled arg2))) + (List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterB) arg2) + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterA) arg1))) + (List.append (List.Cons ((Joint.OP2 (op, (Obj.magic a), (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_reg I8051.RegisterB)))), List.Nil)) + (move globals localss (Bool.andb (sets_carry op) carry_lives_after) dst + (Arg_decision_colour I8051.RegisterA))) + +(** val translate_op2_smart : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.op2 -> + Interference.decision -> arg_decision -> arg_decision -> Joint.joint_seq + List.list **) +let translate_op2_smart globals localss carry_lives_after op dst arg1 arg2 = + preserve_carry_bit globals + (Bool.andb (Bool.andb (Bool.notb (sets_carry op)) carry_lives_after) + (Bool.orb (Bool.orb (arg_is_spilled arg1) (arg_is_spilled arg2)) + (is_spilled dst))) + (match arg2 with + | Arg_decision_colour arg2r -> + List.append + (move globals localss (uses_carry op) (Interference.Decision_colour + I8051.RegisterA) arg1) + (List.append (List.Cons ((Joint.OP2 (op, (Obj.magic a), + (Obj.magic a), (Obj.magic (Joint.hdw_argument_from_reg arg2r)))), + List.Nil)) + (move globals localss + (Bool.andb (sets_carry op) carry_lives_after) dst + (Arg_decision_colour I8051.RegisterA))) + | Arg_decision_spill x -> + (match commutative op with + | Bool.True -> + (match arg1 with + | Arg_decision_colour arg1r -> + List.append + (move globals localss (uses_carry op) + (Interference.Decision_colour I8051.RegisterA) arg2) + (List.append (List.Cons ((Joint.OP2 (op, (Obj.magic a), + (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_reg arg1r)))), + List.Nil)) + (move globals localss + (Bool.andb (sets_carry op) carry_lives_after) dst + (Arg_decision_colour I8051.RegisterA))) + | Arg_decision_spill x0 -> + translate_op2 globals localss carry_lives_after op dst arg1 arg2 + | Arg_decision_imm arg1i -> + List.append + (move globals localss (uses_carry op) + (Interference.Decision_colour I8051.RegisterA) arg2) + (List.append (List.Cons ((Joint.OP2 (op, (Obj.magic a), + (Obj.magic a), + (Obj.magic (Joint.hdw_argument_from_byte arg1i)))), + List.Nil)) + (move globals localss + (Bool.andb (sets_carry op) carry_lives_after) dst + (Arg_decision_colour I8051.RegisterA)))) + | Bool.False -> + translate_op2 globals localss carry_lives_after op dst arg1 arg2) + | Arg_decision_imm arg2i -> + List.append + (move globals localss (uses_carry op) (Interference.Decision_colour + I8051.RegisterA) arg1) + (List.append (List.Cons ((Joint.OP2 (op, (Obj.magic a), + (Obj.magic a), (Obj.magic (Joint.hdw_argument_from_byte arg2i)))), + List.Nil)) + (move globals localss + (Bool.andb (sets_carry op) carry_lives_after) dst + (Arg_decision_colour I8051.RegisterA)))) + +(** val dec_to_arg_dec : Interference.decision -> arg_decision **) +let dec_to_arg_dec = function +| Interference.Decision_spill n -> Arg_decision_spill n +| Interference.Decision_colour r -> Arg_decision_colour r + +(** val reg_to_dec__o__dec_arg_dec__o__inject : + I8051.register -> arg_decision Types.sig0 **) +let reg_to_dec__o__dec_arg_dec__o__inject x0 = + dec_to_arg_dec (Interference.Decision_colour x0) + +(** val dpi1__o__Reg_to_dec__o__dec_arg_dec__o__inject : + (I8051.register, 'a1) Types.dPair -> arg_decision Types.sig0 **) +let dpi1__o__Reg_to_dec__o__dec_arg_dec__o__inject x2 = + dec_to_arg_dec (dpi1__o__Reg_to_dec x2) + +(** val eject__o__Reg_to_dec__o__dec_arg_dec__o__inject : + I8051.register Types.sig0 -> arg_decision Types.sig0 **) +let eject__o__Reg_to_dec__o__dec_arg_dec__o__inject x2 = + dec_to_arg_dec (eject__o__Reg_to_dec x2) + +(** val dpi1__o__dec_arg_dec__o__inject : + (Interference.decision, 'a1) Types.dPair -> arg_decision Types.sig0 **) +let dpi1__o__dec_arg_dec__o__inject x2 = + dec_to_arg_dec x2.Types.dpi1 + +(** val eject__o__dec_arg_dec__o__inject : + Interference.decision Types.sig0 -> arg_decision Types.sig0 **) +let eject__o__dec_arg_dec__o__inject x2 = + dec_to_arg_dec (Types.pi1 x2) + +(** val dec_arg_dec__o__inject : + Interference.decision -> arg_decision Types.sig0 **) +let dec_arg_dec__o__inject x1 = + dec_to_arg_dec x1 + +(** val reg_to_dec__o__dec_arg_dec : I8051.register -> arg_decision **) +let reg_to_dec__o__dec_arg_dec x0 = + dec_to_arg_dec (Interference.Decision_colour x0) + +(** val dpi1__o__Reg_to_dec__o__dec_arg_dec : + (I8051.register, 'a1) Types.dPair -> arg_decision **) +let dpi1__o__Reg_to_dec__o__dec_arg_dec x1 = + dec_to_arg_dec (dpi1__o__Reg_to_dec x1) + +(** val eject__o__Reg_to_dec__o__dec_arg_dec : + I8051.register Types.sig0 -> arg_decision **) +let eject__o__Reg_to_dec__o__dec_arg_dec x1 = + dec_to_arg_dec (eject__o__Reg_to_dec x1) + +(** val dpi1__o__dec_arg_dec : + (Interference.decision, 'a1) Types.dPair -> arg_decision **) +let dpi1__o__dec_arg_dec x1 = + dec_to_arg_dec x1.Types.dpi1 + +(** val eject__o__dec_arg_dec : + Interference.decision Types.sig0 -> arg_decision **) +let eject__o__dec_arg_dec x1 = + dec_to_arg_dec (Types.pi1 x1) + +(** val translate_op1 : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.op1 -> + Interference.decision -> Interference.decision -> Joint.joint_seq + List.list **) +let translate_op1 globals localss carry_lives_after op dst arg = + let preserve_carry = + Bool.andb carry_lives_after (Bool.orb (is_spilled dst) (is_spilled arg)) + in + preserve_carry_bit globals preserve_carry + (List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterA) (dec_to_arg_dec arg)) (List.Cons ((Joint.OP1 (op, + (Obj.magic Types.It), (Obj.magic Types.It))), + (move globals localss Bool.False dst (Arg_decision_colour + I8051.RegisterA))))) + +(** val translate_opaccs : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.opAccs -> + Interference.decision -> Interference.decision -> arg_decision -> + arg_decision -> Joint.joint_seq List.list **) +let translate_opaccs globals localss carry_lives_after op dst1 dst2 arg1 arg2 = + List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterB) arg2) + (List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterA) arg1) (List.Cons ((Joint.OPACCS (op, + (Obj.magic Types.It), (Obj.magic Types.It), (Obj.magic Types.It), + (Obj.magic Types.It))), + (List.append + (move globals localss Bool.False dst1 (Arg_decision_colour + I8051.RegisterA)) + (List.append + (move globals localss Bool.False dst2 (Arg_decision_colour + I8051.RegisterB)) + (match Bool.andb carry_lives_after + (Bool.orb (is_spilled dst1) (is_spilled dst2)) with + | Bool.True -> List.Cons (Joint.CLEAR_CARRY, List.Nil) + | Bool.False -> List.Nil)))))) + +(** val move_to_dp : + AST.ident List.list -> Nat.nat -> arg_decision -> arg_decision -> + Joint.joint_seq List.list **) +let move_to_dp globals localss arg1 arg2 = + match Bool.notb (arg_is_spilled arg1) with + | Bool.True -> + List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterDPH) arg2) + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterDPL) arg1) + | Bool.False -> + (match Bool.notb (arg_is_spilled arg2) with + | Bool.True -> + List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterDPL) arg1) + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterDPH) arg2) + | Bool.False -> + List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterB) arg1) + (List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterDPH) arg2) + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterDPL) (Arg_decision_colour I8051.RegisterB)))) + +(** val translate_store : + AST.ident List.list -> Nat.nat -> Bool.bool -> arg_decision -> + arg_decision -> arg_decision -> Joint.joint_seq List.list **) +let translate_store globals localss carry_lives_after addr1 addr2 src = + preserve_carry_bit globals + (Bool.andb carry_lives_after + (Bool.orb (Bool.orb (arg_is_spilled addr1) (arg_is_spilled addr1)) + (arg_is_spilled src))) + (let move_to_dptr = move_to_dp globals localss addr1 addr2 in + List.append + (match arg_is_spilled src with + | Bool.True -> + List.append + (move globals localss Bool.False (Interference.Decision_colour + I8051.registerST0) src) + (List.append move_to_dptr (List.Cons ((Joint.MOVE + (Obj.magic (Joint_LTL_LIN.To_acc (a, I8051.registerST0)))), + List.Nil))) + | Bool.False -> + List.append move_to_dptr + (move globals localss Bool.False (Interference.Decision_colour + I8051.RegisterA) src)) (List.Cons ((Joint.STORE + ((Obj.magic Types.It), (Obj.magic Types.It), (Obj.magic a))), + List.Nil))) + +(** val translate_load : + AST.ident List.list -> Nat.nat -> Bool.bool -> Interference.decision -> + arg_decision -> arg_decision -> Joint.joint_seq List.list **) +let translate_load globals localss carry_lives_after dst addr1 addr2 = + preserve_carry_bit globals + (Bool.andb carry_lives_after + (Bool.orb (Bool.orb (is_spilled dst) (arg_is_spilled addr1)) + (arg_is_spilled addr1))) + (List.append (move_to_dp globals localss addr1 addr2) + (List.append (List.Cons ((Joint.LOAD ((Obj.magic a), + (Obj.magic Types.It), (Obj.magic Types.It))), List.Nil)) + (move globals localss Bool.False dst (Arg_decision_colour + I8051.RegisterA)))) + +(** val translate_address : + __ List.list -> Nat.nat -> Bool.bool -> __ -> BitVector.word -> + Interference.decision -> Interference.decision -> Joint.joint_seq + List.list **) +let translate_address globals localss carry_lives_after id off addr1 addr2 = + preserve_carry_bit (Obj.magic globals) + (Bool.andb carry_lives_after + (Bool.orb (is_spilled addr1) (is_spilled addr2))) (List.Cons + ((Joint.ADDRESS ((Obj.magic id), off, (Obj.magic Types.It), + (Obj.magic Types.It))), + (List.append + (move (Obj.magic globals) localss Bool.False addr1 (Arg_decision_colour + I8051.RegisterDPL)) + (move (Obj.magic globals) localss Bool.False addr2 (Arg_decision_colour + I8051.RegisterDPH))))) + +(** val translate_step : + AST.ident List.list -> Joint.joint_internal_function -> Nat.nat -> + Fixpoints.valuation -> Interference.coloured_graph -> Nat.nat -> + Graphs.label -> Joint.joint_step -> Blocks.bind_step_block **) +let translate_step globals fn localss after grph stack_sz lbl s = + Bind_new.Bret + (let lookup = fun r -> grph.Interference.colouring (Types.Inl r) in + let lookup_arg = fun a0 -> + match a0 with + | Joint.Reg r -> dec_to_arg_dec (lookup r) + | Joint.Imm b -> Arg_decision_imm b + in + let carry_lives_after = Liveness.hlives I8051.RegisterCarry (after lbl) + in + let move0 = move globals localss carry_lives_after in + (match Liveness.eliminable_step globals (after lbl) s with + | Bool.True -> + let x = + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals List.Nil + in + x + | Bool.False -> + (match s with + | Joint.COST_LABEL cost_lbl -> + { Types.fst = { Types.fst = List.Nil; Types.snd = (fun x -> + Joint.COST_LABEL cost_lbl) }; Types.snd = List.Nil } + | Joint.CALL (f, n_args, x) -> + (match f with + | Types.Inl f0 -> + { Types.fst = { Types.fst = List.Nil; Types.snd = (fun x0 -> + Joint.CALL ((Types.Inl f0), n_args, (Obj.magic Types.It))) }; + Types.snd = List.Nil } + | Types.Inr dp -> + let { Types.fst = dpl; Types.snd = dph } = dp in + { Types.fst = { Types.fst = + (List.append + (Blocks.add_dummy_variance + (move_to_dp globals localss (Obj.magic lookup_arg dpl) + (Obj.magic lookup_arg dph))) (List.Cons ((fun l -> + let x0 = Joint.Extension_seq + (Obj.magic (Joint_LTL_LIN.LOW_ADDRESS (Obj.magic l))) + in + x0), (List.Cons ((fun x0 -> Joint.PUSH (Obj.magic Types.It)), + (List.Cons ((fun l -> Joint.Extension_seq + (Obj.magic (Joint_LTL_LIN.HIGH_ADDRESS (Obj.magic l)))), + (List.Cons ((fun x0 -> Joint.PUSH (Obj.magic Types.It)), + (List.Cons ((fun x0 -> Joint.MOVE + (Obj.magic (Joint_LTL_LIN.Int_to_acc (a, Joint.zero_byte)))), + List.Nil))))))))))); Types.snd = (fun x0 -> Joint.CALL + ((Types.Inr { Types.fst = (Obj.magic Types.It); Types.snd = + (Obj.magic Types.It) }), n_args, (Obj.magic Types.It))) }; + Types.snd = List.Nil }) + | Joint.COND (r, ltrue) -> + { Types.fst = { Types.fst = + (Blocks.add_dummy_variance + (move0 (Interference.Decision_colour I8051.RegisterA) + (dec_to_arg_dec (Obj.magic lookup r)))); Types.snd = + (fun x -> Joint.COND ((Obj.magic Types.It), ltrue)) }; + Types.snd = List.Nil } + | Joint.Step_seq s' -> + (match s' with + | Joint.COMMENT c -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals (List.Cons ((Joint.COMMENT c), List.Nil)) + | Joint.MOVE pair_regs -> + let lookup_move_dst = fun x -> + match x with + | ERTL.PSD r -> lookup r + | ERTL.HDW r -> Interference.Decision_colour r + in + let dst = lookup_move_dst (Obj.magic pair_regs).Types.fst in + let src = + match (Obj.magic pair_regs).Types.snd with + | Joint.Reg r -> dec_to_arg_dec (lookup_move_dst r) + | Joint.Imm b -> Arg_decision_imm b + in + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals (move0 dst src) + | Joint.POP r -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals (List.Cons ((Joint.POP (Obj.magic a)), + (move0 (Obj.magic lookup r) (Arg_decision_colour + I8051.RegisterA)))) + | Joint.PUSH a0 -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (List.append + (move0 (Interference.Decision_colour I8051.RegisterA) + (Obj.magic lookup_arg a0)) (List.Cons ((Joint.PUSH + (Obj.magic a)), List.Nil))) + | Joint.ADDRESS (lbl0, off, dpl, dph) -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (translate_address (Obj.magic globals) localss + carry_lives_after (Obj.magic lbl0) off + (Obj.magic lookup dpl) (Obj.magic lookup dph)) + | Joint.OPACCS (op, dst1, dst2, arg1, arg2) -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (translate_opaccs globals localss carry_lives_after op + (Obj.magic lookup dst1) (Obj.magic lookup dst2) + (Obj.magic lookup_arg arg1) (Obj.magic lookup_arg arg2)) + | Joint.OP1 (op, dst, arg) -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (translate_op1 globals localss carry_lives_after op + (Obj.magic lookup dst) (Obj.magic lookup arg)) + | Joint.OP2 (op, dst, arg1, arg2) -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (translate_op2_smart globals localss carry_lives_after op + (Obj.magic lookup dst) (Obj.magic lookup_arg arg1) + (Obj.magic lookup_arg arg2)) + | Joint.CLEAR_CARRY -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals (List.Cons (Joint.CLEAR_CARRY, List.Nil)) + | Joint.SET_CARRY -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals (List.Cons (Joint.SET_CARRY, List.Nil)) + | Joint.LOAD (dstr, addr1, addr2) -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (translate_load globals localss carry_lives_after + (Obj.magic lookup dstr) (Obj.magic lookup_arg addr1) + (Obj.magic lookup_arg addr2)) + | Joint.STORE (addr1, addr2, srcr) -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (translate_store globals localss carry_lives_after + (Obj.magic lookup_arg addr1) (Obj.magic lookup_arg addr2) + (Obj.magic lookup_arg srcr)) + | Joint.Extension_seq ext -> + Blocks.ensure_step_block (Joint.graph_params_to_params LTL.lTL) + globals + (match Obj.magic ext with + | ERTL.Ertl_new_frame -> newframe globals stack_sz + | ERTL.Ertl_del_frame -> delframe globals stack_sz + | ERTL.Ertl_frame_size r -> + move0 (lookup r) (Arg_decision_imm + (Joint.byte_of_nat stack_sz))))))) + +(** val translate_fin_step : + AST.ident List.list -> Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block **) +let translate_fin_step globals lbl s = + Bind_new.Bret { Types.fst = List.Nil; Types.snd = + (match s with + | Joint.GOTO l -> Joint.GOTO l + | Joint.RETURN -> Joint.RETURN + | Joint.TAILCALL (x, x0) -> assert false (* absurd case *)) } + +(** val translate_data : + Fixpoints.fixpoint_computer -> Interference.coloured_graph_computer -> + AST.ident List.list -> Joint.joint_closed_internal_function -> + (Registers.register, TranslateUtils.b_graph_translate_data) + Bind_new.bind_new **) +let translate_data the_fixpoint build globals int_fun = + let after = + Liveness.analyse_liveness the_fixpoint globals (Types.pi1 int_fun) + in + let coloured_graph = + build globals (Types.pi1 int_fun) + (Fixpoints.fix_lfp Liveness.register_lattice + (Liveness.liveafter globals (Types.pi1 int_fun)) after) + in + let stack_sz = + Nat.plus coloured_graph.Interference.spilled_no + (Types.pi1 int_fun).Joint.joint_if_stacksize + in + Bind_new.Bret { TranslateUtils.init_ret = (Obj.magic Types.It); + TranslateUtils.init_params = (Obj.magic Types.It); + TranslateUtils.init_stack_size = stack_sz; TranslateUtils.added_prologue = + List.Nil; TranslateUtils.new_regs = List.Nil; TranslateUtils.f_step = + (translate_step globals (Types.pi1 int_fun) + (Types.pi1 int_fun).Joint.joint_if_local_stacksize + (Fixpoints.fix_lfp Liveness.register_lattice + (Liveness.liveafter globals (Types.pi1 int_fun)) after) coloured_graph + stack_sz); TranslateUtils.f_fin = (translate_fin_step globals) } + +(** val ertl_to_ltl : + Fixpoints.fixpoint_computer -> Interference.coloured_graph_computer -> + ERTL.ertl_program -> ((LTL.ltl_program, Joint.stack_cost_model) + Types.prod, Nat.nat) Types.prod **) +let ertl_to_ltl the_fixpoint build pr = + let ltlprog = + TranslateUtils.b_graph_transform_program ERTL.eRTL LTL.lTL + (fun globals h -> translate_data the_fixpoint build globals h) pr + in + { Types.fst = { Types.fst = ltlprog; Types.snd = + (Joint.stack_cost (Joint.graph_params_to_params LTL.lTL) ltlprog) }; + Types.snd = + (Nat.minus + (Exp.exp (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) + (Joint.globals_stacksize (Joint.graph_params_to_params LTL.lTL) ltlprog)) } + diff --git a/extracted/eRTLToLTL.mli b/extracted/eRTLToLTL.mli new file mode 100644 index 0000000..7725136 --- /dev/null +++ b/extracted/eRTLToLTL.mli @@ -0,0 +1,372 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open LTL + +open Fixpoints + +open Set_adt + +open ERTL + +open Liveness + +open Interference + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +val dpi1__o__Reg_to_dec__o__inject : + (I8051.register, 'a1) Types.dPair -> Interference.decision Types.sig0 + +val eject__o__Reg_to_dec__o__inject : + I8051.register Types.sig0 -> Interference.decision Types.sig0 + +val reg_to_dec__o__inject : + I8051.register -> Interference.decision Types.sig0 + +val dpi1__o__Reg_to_dec : + (I8051.register, 'a1) Types.dPair -> Interference.decision + +val eject__o__Reg_to_dec : I8051.register Types.sig0 -> Interference.decision + +type arg_decision = +| Arg_decision_colour of I8051.register +| Arg_decision_spill of Nat.nat +| Arg_decision_imm of BitVector.byte + +val arg_decision_rect_Type4 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 + +val arg_decision_rect_Type5 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 + +val arg_decision_rect_Type3 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 + +val arg_decision_rect_Type2 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 + +val arg_decision_rect_Type1 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 + +val arg_decision_rect_Type0 : + (I8051.register -> 'a1) -> (Nat.nat -> 'a1) -> (BitVector.byte -> 'a1) -> + arg_decision -> 'a1 + +val arg_decision_inv_rect_Type4 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> 'a1 + +val arg_decision_inv_rect_Type3 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> 'a1 + +val arg_decision_inv_rect_Type2 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> 'a1 + +val arg_decision_inv_rect_Type1 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> 'a1 + +val arg_decision_inv_rect_Type0 : + arg_decision -> (I8051.register -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> + (BitVector.byte -> __ -> 'a1) -> 'a1 + +val arg_decision_discr : arg_decision -> arg_decision -> __ + +val arg_decision_jmdiscr : arg_decision -> arg_decision -> __ + +val dpi1__o__Reg_to_arg_dec__o__inject : + (I8051.register, 'a1) Types.dPair -> arg_decision Types.sig0 + +val eject__o__Reg_to_arg_dec__o__inject : + I8051.register Types.sig0 -> arg_decision Types.sig0 + +val reg_to_arg_dec__o__inject : I8051.register -> arg_decision Types.sig0 + +val dpi1__o__Reg_to_arg_dec : + (I8051.register, 'a1) Types.dPair -> arg_decision + +val eject__o__Reg_to_arg_dec : I8051.register Types.sig0 -> arg_decision + +val preserve_carry_bit : + AST.ident List.list -> Bool.bool -> Joint.joint_seq List.list -> + Joint.joint_seq List.list + +val a : Types.unit0 + +val dpi1__o__beval_of_byte__o__inject : + (BitVector.byte, 'a1) Types.dPair -> ByteValues.beval Types.sig0 + +val eject__o__beval_of_byte__o__inject : + BitVector.byte Types.sig0 -> ByteValues.beval Types.sig0 + +val beval_of_byte__o__inject : BitVector.byte -> ByteValues.beval Types.sig0 + +val dpi1__o__beval_of_byte : + (BitVector.byte, 'a1) Types.dPair -> ByteValues.beval + +val eject__o__beval_of_byte : BitVector.byte Types.sig0 -> ByteValues.beval + +val set_dp_by_offset : + AST.ident List.list -> Nat.nat -> Joint.joint_seq List.list + +val get_stack : + AST.ident List.list -> Nat.nat -> I8051.register -> Nat.nat -> + Joint.joint_seq List.list + +val set_stack_not_a : + AST.ident List.list -> Nat.nat -> Nat.nat -> I8051.register -> + Joint.joint_seq List.list + +val set_stack_a : + AST.ident List.list -> Nat.nat -> Nat.nat -> Joint.joint_seq List.list + +val set_stack : + AST.ident List.list -> Nat.nat -> Nat.nat -> I8051.register -> + Joint.joint_seq List.list + +val set_stack_int : + AST.ident List.list -> Nat.nat -> Nat.nat -> BitVector.byte -> + Joint.joint_seq List.list + +val move : + AST.ident List.list -> Nat.nat -> Bool.bool -> Interference.decision -> + arg_decision -> Joint.joint_seq List.list + +val arg_is_spilled : arg_decision -> Bool.bool + +val is_spilled : Interference.decision -> Bool.bool + +val newframe : AST.ident List.list -> Nat.nat -> Joint.joint_seq List.list + +val delframe : AST.ident List.list -> Nat.nat -> Joint.joint_seq List.list + +val commutative : BackEndOps.op2 -> Bool.bool + +val uses_carry : BackEndOps.op2 -> Bool.bool + +val sets_carry : BackEndOps.op2 -> Bool.bool + +val translate_op2 : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.op2 -> + Interference.decision -> arg_decision -> arg_decision -> Joint.joint_seq + List.list + +val translate_op2_smart : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.op2 -> + Interference.decision -> arg_decision -> arg_decision -> Joint.joint_seq + List.list + +val dec_to_arg_dec : Interference.decision -> arg_decision + +val reg_to_dec__o__dec_arg_dec__o__inject : + I8051.register -> arg_decision Types.sig0 + +val dpi1__o__Reg_to_dec__o__dec_arg_dec__o__inject : + (I8051.register, 'a1) Types.dPair -> arg_decision Types.sig0 + +val eject__o__Reg_to_dec__o__dec_arg_dec__o__inject : + I8051.register Types.sig0 -> arg_decision Types.sig0 + +val dpi1__o__dec_arg_dec__o__inject : + (Interference.decision, 'a1) Types.dPair -> arg_decision Types.sig0 + +val eject__o__dec_arg_dec__o__inject : + Interference.decision Types.sig0 -> arg_decision Types.sig0 + +val dec_arg_dec__o__inject : Interference.decision -> arg_decision Types.sig0 + +val reg_to_dec__o__dec_arg_dec : I8051.register -> arg_decision + +val dpi1__o__Reg_to_dec__o__dec_arg_dec : + (I8051.register, 'a1) Types.dPair -> arg_decision + +val eject__o__Reg_to_dec__o__dec_arg_dec : + I8051.register Types.sig0 -> arg_decision + +val dpi1__o__dec_arg_dec : + (Interference.decision, 'a1) Types.dPair -> arg_decision + +val eject__o__dec_arg_dec : Interference.decision Types.sig0 -> arg_decision + +val translate_op1 : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.op1 -> + Interference.decision -> Interference.decision -> Joint.joint_seq List.list + +val translate_opaccs : + AST.ident List.list -> Nat.nat -> Bool.bool -> BackEndOps.opAccs -> + Interference.decision -> Interference.decision -> arg_decision -> + arg_decision -> Joint.joint_seq List.list + +val move_to_dp : + AST.ident List.list -> Nat.nat -> arg_decision -> arg_decision -> + Joint.joint_seq List.list + +val translate_store : + AST.ident List.list -> Nat.nat -> Bool.bool -> arg_decision -> arg_decision + -> arg_decision -> Joint.joint_seq List.list + +val translate_load : + AST.ident List.list -> Nat.nat -> Bool.bool -> Interference.decision -> + arg_decision -> arg_decision -> Joint.joint_seq List.list + +val translate_address : + __ List.list -> Nat.nat -> Bool.bool -> __ -> BitVector.word -> + Interference.decision -> Interference.decision -> Joint.joint_seq List.list + +val translate_step : + AST.ident List.list -> Joint.joint_internal_function -> Nat.nat -> + Fixpoints.valuation -> Interference.coloured_graph -> Nat.nat -> + Graphs.label -> Joint.joint_step -> Blocks.bind_step_block + +val translate_fin_step : + AST.ident List.list -> Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block + +val translate_data : + Fixpoints.fixpoint_computer -> Interference.coloured_graph_computer -> + AST.ident List.list -> Joint.joint_closed_internal_function -> + (Registers.register, TranslateUtils.b_graph_translate_data) + Bind_new.bind_new + +val ertl_to_ltl : + Fixpoints.fixpoint_computer -> Interference.coloured_graph_computer -> + ERTL.ertl_program -> ((LTL.ltl_program, Joint.stack_cost_model) Types.prod, + Nat.nat) Types.prod + diff --git a/extracted/eRTL_printer.ml b/extracted/eRTL_printer.ml new file mode 100644 index 0000000..b75c5e2 --- /dev/null +++ b/extracted/eRTL_printer.ml @@ -0,0 +1,133 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open ERTL + +(** val print_ERTL_program : + 'a1 Joint_printer.printing_params -> ERTL.ertl_program -> (AST.ident, 'a1 + List.list) Types.prod List.list **) +let print_ERTL_program pp prog = + Joint_printer.print_joint_program (Joint.graph_params_to_params ERTL.eRTL) + pp prog + (Joint_printer.graph_code_iteration_params ERTL.eRTL + (Joint.prog_names (Joint.graph_params_to_params ERTL.eRTL) prog) pp) + diff --git a/extracted/eRTL_printer.mli b/extracted/eRTL_printer.mli new file mode 100644 index 0000000..27c8d3f --- /dev/null +++ b/extracted/eRTL_printer.mli @@ -0,0 +1,128 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open ERTL + +val print_ERTL_program : + 'a1 Joint_printer.printing_params -> ERTL.ertl_program -> (AST.ident, 'a1 + List.list) Types.prod List.list + diff --git a/extracted/eRTL_semantics.ml b/extracted/eRTL_semantics.ml new file mode 100644 index 0000000..945de89 --- /dev/null +++ b/extracted/eRTL_semantics.ml @@ -0,0 +1,391 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open ERTL + +type ertl_reg_env = + (ByteValues.beval Registers.register_env, SemanticsUtils.hw_register_env) + Types.prod + +(** val ps_reg_store : + PreIdentifiers.identifier -> ByteValues.beval -> ertl_reg_env -> + (ByteValues.beval Identifiers.identifier_map, + SemanticsUtils.hw_register_env) Types.prod Errors.res **) +let ps_reg_store r v local_env = + let res = SemanticsUtils.reg_store r v local_env.Types.fst in + Errors.OK { Types.fst = res; Types.snd = local_env.Types.snd } + +(** val ps_reg_retrieve : + ertl_reg_env -> Registers.register -> ByteValues.beval Errors.res **) +let ps_reg_retrieve local_env = + SemanticsUtils.reg_retrieve local_env.Types.fst + +(** val hw_reg_store : + I8051.register -> ByteValues.beval -> ertl_reg_env -> (ByteValues.beval + Registers.register_env, SemanticsUtils.hw_register_env) Types.prod + Errors.res **) +let hw_reg_store r v local_env = + Errors.OK { Types.fst = local_env.Types.fst; Types.snd = + (SemanticsUtils.hwreg_store r v local_env.Types.snd) } + +(** val hw_reg_retrieve : + ertl_reg_env -> I8051.register -> ByteValues.beval Errors.res **) +let hw_reg_retrieve local_env reg = + Errors.OK (SemanticsUtils.hwreg_retrieve local_env.Types.snd reg) + +(** val ps_arg_retrieve : + ertl_reg_env -> Registers.register Joint.argument -> ByteValues.beval + Errors.res **) +let ps_arg_retrieve local_env = function +| Joint.Reg r -> ps_reg_retrieve local_env r +| Joint.Imm b -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) (ByteValues.BVByte b)) + +(** val get_hwsp : ertl_reg_env -> ByteValues.xpointer Errors.res **) +let get_hwsp st = + SemanticsUtils.hwreg_retrieve_sp st.Types.snd + +(** val set_hwsp : ertl_reg_env -> ByteValues.xpointer -> ertl_reg_env **) +let set_hwsp st sp = + { Types.fst = st.Types.fst; Types.snd = + (SemanticsUtils.hwreg_store_sp st.Types.snd sp) } + +(** val eRTL_state : Joint_semantics.sem_state_params **) +let eRTL_state = + { Joint_semantics.empty_framesT = (Obj.magic List.Nil); + Joint_semantics.empty_regsT = (fun sp -> + Obj.magic { Types.fst = + (Identifiers.empty_map PreIdentifiers.RegisterTag); Types.snd = + (SemanticsUtils.init_hw_register_env sp) }); Joint_semantics.load_sp = + (Obj.magic get_hwsp); Joint_semantics.save_sp = (Obj.magic set_hwsp) } + +(** val ertl_eval_move : + ertl_reg_env -> (ERTL.move_dst, ERTL.move_dst Joint.argument) Types.prod + -> __ **) +let ertl_eval_move env pr = + Monad.m_bind0 (Monad.max_def Errors.res0) + (match pr.Types.snd with + | Joint.Reg src -> + (match src with + | ERTL.PSD r -> Obj.magic (ps_reg_retrieve env r) + | ERTL.HDW r -> Obj.magic (hw_reg_retrieve env r)) + | Joint.Imm b -> + Monad.m_return0 (Monad.max_def Errors.res0) (ByteValues.BVByte b)) + (fun v -> + match pr.Types.fst with + | ERTL.PSD r -> Obj.magic (ps_reg_store r v env) + | ERTL.HDW r -> Obj.magic (hw_reg_store r v env)) + +(** val ertl_allocate_local : + PreIdentifiers.identifier -> ertl_reg_env -> (ByteValues.beval + Identifiers.identifier_map, SemanticsUtils.hw_register_env) Types.prod **) +let ertl_allocate_local reg lenv = + { Types.fst = + (Identifiers.add PreIdentifiers.RegisterTag lenv.Types.fst reg + ByteValues.BVundef); Types.snd = lenv.Types.snd } + +(** val ertl_save_frame : + Joint_semantics.call_kind -> Types.unit0 -> Joint_semantics.state_pc -> + Joint_semantics.state Errors.res **) +let ertl_save_frame x x0 st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Joint_semantics.push_ra eRTL_state st.Joint_semantics.st_no_pc + st.Joint_semantics.pc)) (fun st' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.FrameErrorOnPush), List.Nil)) + st'.Joint_semantics.st_frms)) (fun frms -> + Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_frms eRTL_state + (Obj.magic (List.Cons ({ Types.fst = + (Obj.magic st'.Joint_semantics.regs).Types.fst; Types.snd = + st.Joint_semantics.pc.ByteValues.pc_block }, frms))) + (Joint_semantics.set_regs eRTL_state + (Obj.magic { Types.fst = + (Identifiers.empty_map PreIdentifiers.RegisterTag); + Types.snd = (Obj.magic st'.Joint_semantics.regs).Types.snd }) + st'))))) + +(** val ertl_pop_frame : + Joint_semantics.state -> (Joint_semantics.state, + ByteValues.program_counter) Types.prod Errors.res **) +let ertl_pop_frame st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.FrameErrorOnPop), List.Nil)) + st.Joint_semantics.st_frms)) (fun frms -> + match frms with + | List.Nil -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.FramesEmptyOnPop), List.Nil))) + | List.Cons (hd, tl) -> + let { Types.fst = local_mem; Types.snd = bl } = hd in + let st' = + Joint_semantics.set_regs eRTL_state + (Obj.magic { Types.fst = local_mem; Types.snd = + (Obj.magic st.Joint_semantics.regs).Types.snd }) + (Joint_semantics.set_frms eRTL_state (Obj.magic tl) st) + in + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.pop_ra eRTL_state st')) (fun st'' pc -> + match Pointers.eq_block (Types.pi1 bl) + (Types.pi1 pc.ByteValues.pc_block) with + | Bool.True -> + Obj.magic (Errors.OK { Types.fst = st''; Types.snd = pc }) + | Bool.False -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BlockInFramesCorrupted), List.Nil)))))) + +(** val ertl_fetch_external_args : + AST.external_function -> Joint_semantics.state -> __ -> Values.val0 + List.list Errors.res **) +let ertl_fetch_external_args _ = + failwith "AXIOM TO BE REALIZED" + +(** val ertl_set_result : + Values.val0 List.list -> Types.unit0 -> Joint_semantics.state -> + Joint_semantics.state Errors.res **) +let ertl_set_result _ = + failwith "AXIOM TO BE REALIZED" + +(** val ps_reg_store_status : + Registers.register -> ByteValues.beval -> Joint_semantics.state -> + Joint_semantics.state Errors.res **) +let ps_reg_store_status dst v st = + let env = st.Joint_semantics.regs in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ps_reg_store dst v (Obj.magic env))) (fun env' -> + Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_regs eRTL_state env' st))) + +(** val eval_ertl_seq : + AST.ident List.list -> 'a1 Joint_semantics.genv_gen -> ERTL.ertl_seq -> + AST.ident -> Joint_semantics.state -> Joint_semantics.state Errors.res **) +let eval_ertl_seq globals ge stm id st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FunctionNotFound) + (ge.Joint_semantics.stack_sizes id))) (fun framesize -> + let framesize0 = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) framesize + in + (match stm with + | ERTL.Ertl_new_frame -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.sp eRTL_state st)) (fun sp -> + let newsp = + Pointers.neg_shift_pointer (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Types.pi1 sp) framesize0 + in + Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_sp eRTL_state newsp st)) + | ERTL.Ertl_del_frame -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.sp eRTL_state st)) (fun sp -> + let newsp = + Pointers.shift_pointer (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Types.pi1 sp) framesize0 + in + Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_sp eRTL_state newsp st)) + | ERTL.Ertl_frame_size dst -> + Obj.magic + (ps_reg_store_status dst (ByteValues.BVByte framesize0) st)))) + +(** val eRTL_sem_uns : 'a1 Joint_semantics.sem_unserialized_params **) +let eRTL_sem_uns = + { Joint_semantics.st_pars = eRTL_state; Joint_semantics.acca_store_ = + (Obj.magic ps_reg_store); Joint_semantics.acca_retrieve_ = + (Obj.magic ps_reg_retrieve); Joint_semantics.acca_arg_retrieve_ = + (Obj.magic ps_arg_retrieve); Joint_semantics.accb_store_ = + (Obj.magic ps_reg_store); Joint_semantics.accb_retrieve_ = + (Obj.magic ps_reg_retrieve); Joint_semantics.accb_arg_retrieve_ = + (Obj.magic ps_arg_retrieve); Joint_semantics.dpl_store_ = + (Obj.magic ps_reg_store); Joint_semantics.dpl_retrieve_ = + (Obj.magic ps_reg_retrieve); Joint_semantics.dpl_arg_retrieve_ = + (Obj.magic ps_arg_retrieve); Joint_semantics.dph_store_ = + (Obj.magic ps_reg_store); Joint_semantics.dph_retrieve_ = + (Obj.magic ps_reg_retrieve); Joint_semantics.dph_arg_retrieve_ = + (Obj.magic ps_arg_retrieve); Joint_semantics.snd_arg_retrieve_ = + (Obj.magic ps_arg_retrieve); Joint_semantics.pair_reg_move_ = + (Obj.magic ertl_eval_move); Joint_semantics.save_frame = + (Obj.magic ertl_save_frame); Joint_semantics.setup_call = + (fun x x0 x1 st -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st)); + Joint_semantics.fetch_external_args = ertl_fetch_external_args; + Joint_semantics.set_result = (Obj.magic ertl_set_result); + Joint_semantics.call_args_for_main = (Obj.magic Nat.O); + Joint_semantics.call_dest_for_main = (Obj.magic Types.It); + Joint_semantics.read_result = (fun x x0 x1 st -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + (List.map + (SemanticsUtils.hwreg_retrieve + (Obj.magic st.Joint_semantics.regs).Types.snd) + I8051.registerRets))); Joint_semantics.eval_ext_seq = + (fun gl ge stm id -> eval_ertl_seq gl ge (Obj.magic stm) id); + Joint_semantics.pop_frame = (fun x x0 x1 x2 -> ertl_pop_frame) } + +(** val eRTL_semantics : SemanticsUtils.sem_graph_params **) +let eRTL_semantics = + { SemanticsUtils.sgp_pars = + (Joint.gp_to_p__o__stmt_pars__o__uns_pars ERTL.eRTL); + SemanticsUtils.sgp_sup = (fun _ -> eRTL_sem_uns); + SemanticsUtils.graph_pre_main_generator = ERTL.eRTL_premain } + diff --git a/extracted/eRTL_semantics.mli b/extracted/eRTL_semantics.mli new file mode 100644 index 0000000..5375117 --- /dev/null +++ b/extracted/eRTL_semantics.mli @@ -0,0 +1,218 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open ERTL + +type ertl_reg_env = + (ByteValues.beval Registers.register_env, SemanticsUtils.hw_register_env) + Types.prod + +val ps_reg_store : + PreIdentifiers.identifier -> ByteValues.beval -> ertl_reg_env -> + (ByteValues.beval Identifiers.identifier_map, + SemanticsUtils.hw_register_env) Types.prod Errors.res + +val ps_reg_retrieve : + ertl_reg_env -> Registers.register -> ByteValues.beval Errors.res + +val hw_reg_store : + I8051.register -> ByteValues.beval -> ertl_reg_env -> (ByteValues.beval + Registers.register_env, SemanticsUtils.hw_register_env) Types.prod + Errors.res + +val hw_reg_retrieve : + ertl_reg_env -> I8051.register -> ByteValues.beval Errors.res + +val ps_arg_retrieve : + ertl_reg_env -> Registers.register Joint.argument -> ByteValues.beval + Errors.res + +val get_hwsp : ertl_reg_env -> ByteValues.xpointer Errors.res + +val set_hwsp : ertl_reg_env -> ByteValues.xpointer -> ertl_reg_env + +val eRTL_state : Joint_semantics.sem_state_params + +val ertl_eval_move : + ertl_reg_env -> (ERTL.move_dst, ERTL.move_dst Joint.argument) Types.prod -> + __ + +val ertl_allocate_local : + PreIdentifiers.identifier -> ertl_reg_env -> (ByteValues.beval + Identifiers.identifier_map, SemanticsUtils.hw_register_env) Types.prod + +val ertl_save_frame : + Joint_semantics.call_kind -> Types.unit0 -> Joint_semantics.state_pc -> + Joint_semantics.state Errors.res + +val ertl_pop_frame : + Joint_semantics.state -> (Joint_semantics.state, + ByteValues.program_counter) Types.prod Errors.res + +val ertl_fetch_external_args : + AST.external_function -> Joint_semantics.state -> __ -> Values.val0 + List.list Errors.res + +val ertl_set_result : + Values.val0 List.list -> Types.unit0 -> Joint_semantics.state -> + Joint_semantics.state Errors.res + +val ps_reg_store_status : + Registers.register -> ByteValues.beval -> Joint_semantics.state -> + Joint_semantics.state Errors.res + +val eval_ertl_seq : + AST.ident List.list -> 'a1 Joint_semantics.genv_gen -> ERTL.ertl_seq -> + AST.ident -> Joint_semantics.state -> Joint_semantics.state Errors.res + +val eRTL_sem_uns : __ Joint_semantics.sem_unserialized_params + +val eRTL_semantics : SemanticsUtils.sem_graph_params + diff --git a/extracted/errorMessages.ml b/extracted/errorMessages.ml new file mode 100644 index 0000000..2076f3d --- /dev/null +++ b/extracted/errorMessages.ml @@ -0,0 +1,84 @@ +open Preamble + +open Core_notation + +open Pts + +type errorMessage = +| MISSING +| EXTERNAL +| AssemblyTooLarge +| Jump_expansion_failed +| ValueIsNotABoolean +| BadCast +| BadlyTypedTerm +| UnknownIdentifier +| BadLvalueTerm +| FailedLoad +| FailedOp +| WrongNumberOfParameters +| FailedStore +| NonsenseState +| ReturnMismatch +| UnknownLabel +| BadFunctionValue +| MainMissing +| UnknownField +| UndeclaredIdentifier +| BadlyTypedAccess +| BadLvalue +| MissingField +| FIXME +| MissingLabel +| ParamGlobalMixup +| DuplicateLabel +| TypeMismatch +| UnknownLocal +| FailedConstant +| BadState +| StoppedMidIO +| UnsupportedOp +| CorruptedPointer +| NotATwoBytesPointer +| ValueNotABoolean +| NotAnInt32Val +| WrongLength +| InitDataStoreFailed +| DuplicateVariable +| MissingId +| IllTypedEvent +| InternalStackFull +| InternalStackEmpty +| BadProgramCounter +| ProgramCounterOutOfCode +| PointNotFound +| LabelNotFound +| MissingSymbol +| BadFunction +| SuccessorNotProvided +| BadPointer +| NoSuccessor +| MissingStackSize +| ExternalMain +| BadRegister +| BadMain +| MissingRegister +| MissingStatement +| BadJumpTable +| BadJumpValue +| FinalState +| EmptyStack +| OutOfBounds +| UnexpectedIO +| TerminatedEarly +| BadCostLabelling +| RepeatedCostLabel +| NotTerminated +| RepeatedCostLabel0 +| FramesEmptyOnPop +| BlockInFramesCorrupted +| FrameErrorOnPush +| FrameErrorOnPop +| FunctionNotFound +| StackOverflow + diff --git a/extracted/errorMessages.mli b/extracted/errorMessages.mli new file mode 100644 index 0000000..2076f3d --- /dev/null +++ b/extracted/errorMessages.mli @@ -0,0 +1,84 @@ +open Preamble + +open Core_notation + +open Pts + +type errorMessage = +| MISSING +| EXTERNAL +| AssemblyTooLarge +| Jump_expansion_failed +| ValueIsNotABoolean +| BadCast +| BadlyTypedTerm +| UnknownIdentifier +| BadLvalueTerm +| FailedLoad +| FailedOp +| WrongNumberOfParameters +| FailedStore +| NonsenseState +| ReturnMismatch +| UnknownLabel +| BadFunctionValue +| MainMissing +| UnknownField +| UndeclaredIdentifier +| BadlyTypedAccess +| BadLvalue +| MissingField +| FIXME +| MissingLabel +| ParamGlobalMixup +| DuplicateLabel +| TypeMismatch +| UnknownLocal +| FailedConstant +| BadState +| StoppedMidIO +| UnsupportedOp +| CorruptedPointer +| NotATwoBytesPointer +| ValueNotABoolean +| NotAnInt32Val +| WrongLength +| InitDataStoreFailed +| DuplicateVariable +| MissingId +| IllTypedEvent +| InternalStackFull +| InternalStackEmpty +| BadProgramCounter +| ProgramCounterOutOfCode +| PointNotFound +| LabelNotFound +| MissingSymbol +| BadFunction +| SuccessorNotProvided +| BadPointer +| NoSuccessor +| MissingStackSize +| ExternalMain +| BadRegister +| BadMain +| MissingRegister +| MissingStatement +| BadJumpTable +| BadJumpValue +| FinalState +| EmptyStack +| OutOfBounds +| UnexpectedIO +| TerminatedEarly +| BadCostLabelling +| RepeatedCostLabel +| NotTerminated +| RepeatedCostLabel0 +| FramesEmptyOnPop +| BlockInFramesCorrupted +| FrameErrorOnPush +| FrameErrorOnPop +| FunctionNotFound +| StackOverflow + diff --git a/extracted/errors.ml b/extracted/errors.ml new file mode 100644 index 0000000..72cb0d9 --- /dev/null +++ b/extracted/errors.ml @@ -0,0 +1,318 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open List + +open Positive + +open PreIdentifiers + +open Jmeq + +open Russell + +open Setoids + +open Monad + +open Option + +open ErrorMessages + +type errcode = +| MSG of ErrorMessages.errorMessage +| CTX of PreIdentifiers.identifierTag * PreIdentifiers.identifier + +(** val errcode_rect_Type4 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 **) +let rec errcode_rect_Type4 h_MSG h_CTX = function +| MSG x_3113 -> h_MSG x_3113 +| CTX (tag, x_3114) -> h_CTX tag x_3114 + +(** val errcode_rect_Type5 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 **) +let rec errcode_rect_Type5 h_MSG h_CTX = function +| MSG x_3118 -> h_MSG x_3118 +| CTX (tag, x_3119) -> h_CTX tag x_3119 + +(** val errcode_rect_Type3 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 **) +let rec errcode_rect_Type3 h_MSG h_CTX = function +| MSG x_3123 -> h_MSG x_3123 +| CTX (tag, x_3124) -> h_CTX tag x_3124 + +(** val errcode_rect_Type2 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 **) +let rec errcode_rect_Type2 h_MSG h_CTX = function +| MSG x_3128 -> h_MSG x_3128 +| CTX (tag, x_3129) -> h_CTX tag x_3129 + +(** val errcode_rect_Type1 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 **) +let rec errcode_rect_Type1 h_MSG h_CTX = function +| MSG x_3133 -> h_MSG x_3133 +| CTX (tag, x_3134) -> h_CTX tag x_3134 + +(** val errcode_rect_Type0 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 **) +let rec errcode_rect_Type0 h_MSG h_CTX = function +| MSG x_3138 -> h_MSG x_3138 +| CTX (tag, x_3139) -> h_CTX tag x_3139 + +(** val errcode_inv_rect_Type4 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) + -> 'a1 **) +let errcode_inv_rect_Type4 hterm h1 h2 = + let hcut = errcode_rect_Type4 h1 h2 hterm in hcut __ + +(** val errcode_inv_rect_Type3 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) + -> 'a1 **) +let errcode_inv_rect_Type3 hterm h1 h2 = + let hcut = errcode_rect_Type3 h1 h2 hterm in hcut __ + +(** val errcode_inv_rect_Type2 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) + -> 'a1 **) +let errcode_inv_rect_Type2 hterm h1 h2 = + let hcut = errcode_rect_Type2 h1 h2 hterm in hcut __ + +(** val errcode_inv_rect_Type1 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) + -> 'a1 **) +let errcode_inv_rect_Type1 hterm h1 h2 = + let hcut = errcode_rect_Type1 h1 h2 hterm in hcut __ + +(** val errcode_inv_rect_Type0 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) + -> 'a1 **) +let errcode_inv_rect_Type0 hterm h1 h2 = + let hcut = errcode_rect_Type0 h1 h2 hterm in hcut __ + +(** val errcode_discr : errcode -> errcode -> __ **) +let errcode_discr x y = + Logic.eq_rect_Type2 x + (match x with + | MSG a0 -> Obj.magic (fun _ dH -> dH __) + | CTX (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val errcode_jmdiscr : errcode -> errcode -> __ **) +let errcode_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | MSG a0 -> Obj.magic (fun _ dH -> dH __) + | CTX (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +type errmsg = errcode List.list + +(** val msg : ErrorMessages.errorMessage -> errmsg **) +let msg s = + List.Cons ((MSG s), List.Nil) + +type 'a res = +| OK of 'a +| Error of errmsg + +(** val res_rect_Type4 : + ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 **) +let rec res_rect_Type4 h_OK h_Error = function +| OK x_3178 -> h_OK x_3178 +| Error x_3179 -> h_Error x_3179 + +(** val res_rect_Type5 : + ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 **) +let rec res_rect_Type5 h_OK h_Error = function +| OK x_3183 -> h_OK x_3183 +| Error x_3184 -> h_Error x_3184 + +(** val res_rect_Type3 : + ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 **) +let rec res_rect_Type3 h_OK h_Error = function +| OK x_3188 -> h_OK x_3188 +| Error x_3189 -> h_Error x_3189 + +(** val res_rect_Type2 : + ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 **) +let rec res_rect_Type2 h_OK h_Error = function +| OK x_3193 -> h_OK x_3193 +| Error x_3194 -> h_Error x_3194 + +(** val res_rect_Type1 : + ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 **) +let rec res_rect_Type1 h_OK h_Error = function +| OK x_3198 -> h_OK x_3198 +| Error x_3199 -> h_Error x_3199 + +(** val res_rect_Type0 : + ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 **) +let rec res_rect_Type0 h_OK h_Error = function +| OK x_3203 -> h_OK x_3203 +| Error x_3204 -> h_Error x_3204 + +(** val res_inv_rect_Type4 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 **) +let res_inv_rect_Type4 hterm h1 h2 = + let hcut = res_rect_Type4 h1 h2 hterm in hcut __ + +(** val res_inv_rect_Type3 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 **) +let res_inv_rect_Type3 hterm h1 h2 = + let hcut = res_rect_Type3 h1 h2 hterm in hcut __ + +(** val res_inv_rect_Type2 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 **) +let res_inv_rect_Type2 hterm h1 h2 = + let hcut = res_rect_Type2 h1 h2 hterm in hcut __ + +(** val res_inv_rect_Type1 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 **) +let res_inv_rect_Type1 hterm h1 h2 = + let hcut = res_rect_Type1 h1 h2 hterm in hcut __ + +(** val res_inv_rect_Type0 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 **) +let res_inv_rect_Type0 hterm h1 h2 = + let hcut = res_rect_Type0 h1 h2 hterm in hcut __ + +(** val res_discr : 'a1 res -> 'a1 res -> __ **) +let res_discr x y = + Logic.eq_rect_Type2 x + (match x with + | OK a0 -> Obj.magic (fun _ dH -> dH __) + | Error a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val res_jmdiscr : 'a1 res -> 'a1 res -> __ **) +let res_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | OK a0 -> Obj.magic (fun _ dH -> dH __) + | Error a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val res0 : Monad.monadProps **) +let res0 = + Monad.makeMonadProps (fun _ x -> OK x) (fun _ _ m f -> + match m with + | OK x -> f x + | Error msg0 -> Error msg0) + +(** val mfold_left_i_aux : + (Nat.nat -> 'a1 -> 'a2 -> 'a1 res) -> 'a1 res -> Nat.nat -> 'a2 List.list + -> __ **) +let rec mfold_left_i_aux f x i = function +| List.Nil -> Obj.magic x +| List.Cons (hd, tl) -> + Monad.m_bind0 (Monad.max_def res0) (Obj.magic x) (fun x0 -> + mfold_left_i_aux f (f i x0 hd) (Nat.S i) tl) + +(** val mfold_left_i : + (Nat.nat -> 'a1 -> 'a2 -> 'a1 res) -> 'a1 res -> 'a2 List.list -> __ **) +let mfold_left_i f x = + mfold_left_i_aux f x Nat.O + +(** val mfold_left2 : + ('a1 -> 'a2 -> 'a3 -> 'a1 res) -> 'a1 res -> 'a2 List.list -> 'a3 + List.list -> 'a1 res **) +let rec mfold_left2 f accu left right = + match left with + | List.Nil -> + (match right with + | List.Nil -> accu + | List.Cons (hd, tl) -> Error (msg ErrorMessages.WrongLength)) + | List.Cons (hd, tl) -> + (match right with + | List.Nil -> Error (msg ErrorMessages.WrongLength) + | List.Cons (hd', tl') -> + Obj.magic + (Monad.m_bind0 (Monad.max_def res0) (Obj.magic accu) (fun accu0 -> + Obj.magic (mfold_left2 f (f accu0 hd hd') tl tl')))) + +(** val opt_to_res : errmsg -> 'a1 Types.option -> 'a1 res **) +let opt_to_res msg0 = function +| Types.None -> Error msg0 +| Types.Some v0 -> OK v0 + +(** val jmeq_to_eq__o__opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 **) +let jmeq_to_eq__o__opt_eq_from_res__o__inject x1 x2 x3 = + __ + +(** val dpi1__o__opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> (__, 'a2) Types.dPair -> __ + Types.sig0 **) +let dpi1__o__opt_eq_from_res__o__inject x1 x2 x3 x6 = + __ + +(** val eject__o__opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 -> __ Types.sig0 **) +let eject__o__opt_eq_from_res__o__inject x1 x2 x3 x6 = + __ + +(** val opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 **) +let opt_eq_from_res__o__inject x1 x2 x3 = + __ + +(** val bind_eq : 'a1 res -> ('a1 -> __ -> 'a2 res) -> 'a2 res **) +let bind_eq f g = + (match f with + | OK x -> g x + | Error msg0 -> (fun _ -> Error msg0)) __ + +(** val bind2_eq : + ('a1, 'a2) Types.prod res -> ('a1 -> 'a2 -> __ -> 'a3 res) -> 'a3 res **) +let bind2_eq f g = + (match f with + | OK x -> let { Types.fst = a; Types.snd = b } = x in g a b + | Error msg0 -> (fun _ -> Error msg0)) __ + +(** val res_to_opt : 'a1 res -> 'a1 Types.option **) +let res_to_opt = function +| OK v0 -> Types.Some v0 +| Error x -> Types.None + +(** val bind : __ -> ('a1 -> __) -> __ **) +let bind x_768 x_769 = + Monad.m_bind0 (Monad.max_def res0) x_768 x_769 + +(** val bind2 : __ -> ('a1 -> 'a2 -> __) -> __ **) +let bind2 m f = + Monad.m_bind2 (Monad.max_def res0) m f + +(** val bind3 : __ -> ('a1 -> 'a2 -> 'a3 -> __) -> __ **) +let bind3 x x0 = + Monad.m_bind3 (Monad.max_def res0) x x0 + +(** val mmap : ('a1 -> __) -> 'a1 List.list -> __ **) +let mmap x x0 = + Monad.m_list_map (Monad.max_def res0) x x0 + +(** val mmap_sigma : ('a1 -> __) -> 'a1 List.list -> __ **) +let mmap_sigma x x0 = + Monad.m_list_map_sigma (Monad.max_def res0) x x0 + diff --git a/extracted/errors.mli b/extracted/errors.mli new file mode 100644 index 0000000..0c64aac --- /dev/null +++ b/extracted/errors.mli @@ -0,0 +1,176 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open List + +open Positive + +open PreIdentifiers + +open Jmeq + +open Russell + +open Setoids + +open Monad + +open Option + +open ErrorMessages + +type errcode = +| MSG of ErrorMessages.errorMessage +| CTX of PreIdentifiers.identifierTag * PreIdentifiers.identifier + +val errcode_rect_Type4 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 + +val errcode_rect_Type5 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 + +val errcode_rect_Type3 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 + +val errcode_rect_Type2 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 + +val errcode_rect_Type1 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 + +val errcode_rect_Type0 : + (ErrorMessages.errorMessage -> 'a1) -> (PreIdentifiers.identifierTag -> + PreIdentifiers.identifier -> 'a1) -> errcode -> 'a1 + +val errcode_inv_rect_Type4 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) -> + 'a1 + +val errcode_inv_rect_Type3 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) -> + 'a1 + +val errcode_inv_rect_Type2 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) -> + 'a1 + +val errcode_inv_rect_Type1 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) -> + 'a1 + +val errcode_inv_rect_Type0 : + errcode -> (ErrorMessages.errorMessage -> __ -> 'a1) -> + (PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> __ -> 'a1) -> + 'a1 + +val errcode_discr : errcode -> errcode -> __ + +val errcode_jmdiscr : errcode -> errcode -> __ + +type errmsg = errcode List.list + +val msg : ErrorMessages.errorMessage -> errmsg + +type 'a res = +| OK of 'a +| Error of errmsg + +val res_rect_Type4 : ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 + +val res_rect_Type5 : ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 + +val res_rect_Type3 : ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 + +val res_rect_Type2 : ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 + +val res_rect_Type1 : ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 + +val res_rect_Type0 : ('a1 -> 'a2) -> (errmsg -> 'a2) -> 'a1 res -> 'a2 + +val res_inv_rect_Type4 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 + +val res_inv_rect_Type3 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 + +val res_inv_rect_Type2 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 + +val res_inv_rect_Type1 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 + +val res_inv_rect_Type0 : + 'a1 res -> ('a1 -> __ -> 'a2) -> (errmsg -> __ -> 'a2) -> 'a2 + +val res_discr : 'a1 res -> 'a1 res -> __ + +val res_jmdiscr : 'a1 res -> 'a1 res -> __ + +val res0 : Monad.monadProps + +val mfold_left_i_aux : + (Nat.nat -> 'a1 -> 'a2 -> 'a1 res) -> 'a1 res -> Nat.nat -> 'a2 List.list + -> __ + +val mfold_left_i : + (Nat.nat -> 'a1 -> 'a2 -> 'a1 res) -> 'a1 res -> 'a2 List.list -> __ + +val mfold_left2 : + ('a1 -> 'a2 -> 'a3 -> 'a1 res) -> 'a1 res -> 'a2 List.list -> 'a3 List.list + -> 'a1 res + +val opt_to_res : errmsg -> 'a1 Types.option -> 'a1 res + +val jmeq_to_eq__o__opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 + +val dpi1__o__opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> (__, 'a2) Types.dPair -> __ Types.sig0 + +val eject__o__opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 -> __ Types.sig0 + +val opt_eq_from_res__o__inject : + errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 + +val bind_eq : 'a1 res -> ('a1 -> __ -> 'a2 res) -> 'a2 res + +val bind2_eq : + ('a1, 'a2) Types.prod res -> ('a1 -> 'a2 -> __ -> 'a3 res) -> 'a3 res + +val res_to_opt : 'a1 res -> 'a1 Types.option + +val bind : __ -> ('a1 -> __) -> __ + +val bind2 : __ -> ('a1 -> 'a2 -> __) -> __ + +val bind3 : __ -> ('a1 -> 'a2 -> 'a3 -> __) -> __ + +val mmap : ('a1 -> __) -> 'a1 List.list -> __ + +val mmap_sigma : ('a1 -> __) -> 'a1 List.list -> __ + diff --git a/extracted/events.ml b/extracted/events.ml new file mode 100644 index 0000000..003c350 --- /dev/null +++ b/extracted/events.ml @@ -0,0 +1,379 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open CostLabel + +type eventval = +| EVint of AST.intsize * AST.bvint + +(** val eventval_rect_Type4 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 **) +let rec eventval_rect_Type4 h_EVint = function +| EVint (sz, x_5537) -> h_EVint sz x_5537 + +(** val eventval_rect_Type5 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 **) +let rec eventval_rect_Type5 h_EVint = function +| EVint (sz, x_5540) -> h_EVint sz x_5540 + +(** val eventval_rect_Type3 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 **) +let rec eventval_rect_Type3 h_EVint = function +| EVint (sz, x_5543) -> h_EVint sz x_5543 + +(** val eventval_rect_Type2 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 **) +let rec eventval_rect_Type2 h_EVint = function +| EVint (sz, x_5546) -> h_EVint sz x_5546 + +(** val eventval_rect_Type1 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 **) +let rec eventval_rect_Type1 h_EVint = function +| EVint (sz, x_5549) -> h_EVint sz x_5549 + +(** val eventval_rect_Type0 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 **) +let rec eventval_rect_Type0 h_EVint = function +| EVint (sz, x_5552) -> h_EVint sz x_5552 + +(** val eventval_inv_rect_Type4 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 **) +let eventval_inv_rect_Type4 hterm h1 = + let hcut = eventval_rect_Type4 h1 hterm in hcut __ + +(** val eventval_inv_rect_Type3 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 **) +let eventval_inv_rect_Type3 hterm h1 = + let hcut = eventval_rect_Type3 h1 hterm in hcut __ + +(** val eventval_inv_rect_Type2 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 **) +let eventval_inv_rect_Type2 hterm h1 = + let hcut = eventval_rect_Type2 h1 hterm in hcut __ + +(** val eventval_inv_rect_Type1 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 **) +let eventval_inv_rect_Type1 hterm h1 = + let hcut = eventval_rect_Type1 h1 hterm in hcut __ + +(** val eventval_inv_rect_Type0 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 **) +let eventval_inv_rect_Type0 hterm h1 = + let hcut = eventval_rect_Type0 h1 hterm in hcut __ + +(** val eventval_discr : eventval -> eventval -> __ **) +let eventval_discr x y = + Logic.eq_rect_Type2 x + (let EVint (a0, a1) = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val eventval_jmdiscr : eventval -> eventval -> __ **) +let eventval_jmdiscr x y = + Logic.eq_rect_Type2 x + (let EVint (a0, a1) = x in Obj.magic (fun _ dH -> dH __ __)) y + +type event = +| EVcost of CostLabel.costlabel +| EVextcall of AST.ident * eventval List.list * eventval + +(** val event_rect_Type4 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 **) +let rec event_rect_Type4 h_EVcost h_EVextcall = function +| EVcost x_5577 -> h_EVcost x_5577 +| EVextcall (ev_name, ev_args, ev_res) -> h_EVextcall ev_name ev_args ev_res + +(** val event_rect_Type5 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 **) +let rec event_rect_Type5 h_EVcost h_EVextcall = function +| EVcost x_5581 -> h_EVcost x_5581 +| EVextcall (ev_name, ev_args, ev_res) -> h_EVextcall ev_name ev_args ev_res + +(** val event_rect_Type3 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 **) +let rec event_rect_Type3 h_EVcost h_EVextcall = function +| EVcost x_5585 -> h_EVcost x_5585 +| EVextcall (ev_name, ev_args, ev_res) -> h_EVextcall ev_name ev_args ev_res + +(** val event_rect_Type2 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 **) +let rec event_rect_Type2 h_EVcost h_EVextcall = function +| EVcost x_5589 -> h_EVcost x_5589 +| EVextcall (ev_name, ev_args, ev_res) -> h_EVextcall ev_name ev_args ev_res + +(** val event_rect_Type1 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 **) +let rec event_rect_Type1 h_EVcost h_EVextcall = function +| EVcost x_5593 -> h_EVcost x_5593 +| EVextcall (ev_name, ev_args, ev_res) -> h_EVextcall ev_name ev_args ev_res + +(** val event_rect_Type0 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 **) +let rec event_rect_Type0 h_EVcost h_EVextcall = function +| EVcost x_5597 -> h_EVcost x_5597 +| EVextcall (ev_name, ev_args, ev_res) -> h_EVextcall ev_name ev_args ev_res + +(** val event_inv_rect_Type4 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 **) +let event_inv_rect_Type4 hterm h1 h2 = + let hcut = event_rect_Type4 h1 h2 hterm in hcut __ + +(** val event_inv_rect_Type3 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 **) +let event_inv_rect_Type3 hterm h1 h2 = + let hcut = event_rect_Type3 h1 h2 hterm in hcut __ + +(** val event_inv_rect_Type2 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 **) +let event_inv_rect_Type2 hterm h1 h2 = + let hcut = event_rect_Type2 h1 h2 hterm in hcut __ + +(** val event_inv_rect_Type1 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 **) +let event_inv_rect_Type1 hterm h1 h2 = + let hcut = event_rect_Type1 h1 h2 hterm in hcut __ + +(** val event_inv_rect_Type0 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 **) +let event_inv_rect_Type0 hterm h1 h2 = + let hcut = event_rect_Type0 h1 h2 hterm in hcut __ + +(** val event_discr : event -> event -> __ **) +let event_discr x y = + Logic.eq_rect_Type2 x + (match x with + | EVcost a0 -> Obj.magic (fun _ dH -> dH __) + | EVextcall (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val event_jmdiscr : event -> event -> __ **) +let event_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | EVcost a0 -> Obj.magic (fun _ dH -> dH __) + | EVextcall (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +type trace = event List.list + +(** val e0 : trace **) +let e0 = + List.Nil + +(** val echarge : CostLabel.costlabel -> trace **) +let echarge label = + List.Cons ((EVcost label), List.Nil) + +(** val eextcall : AST.ident -> eventval List.list -> eventval -> trace **) +let eextcall name args res = + List.Cons ((EVextcall (name, args, res)), List.Nil) + +(** val eapp : trace -> trace -> trace **) +let eapp t1 t2 = + List.append t1 t2 + +type traceinf = __traceinf Lazy.t +and __traceinf = +| Econsinf of event * traceinf + +(** val traceinf_inv_rect_Type4 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 **) +let traceinf_inv_rect_Type4 hterm h1 = + let hcut = let Econsinf (x, x0) = Lazy.force hterm in h1 x x0 in hcut __ + +(** val traceinf_inv_rect_Type3 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 **) +let traceinf_inv_rect_Type3 hterm h1 = + let hcut = let Econsinf (x, x0) = Lazy.force hterm in h1 x x0 in hcut __ + +(** val traceinf_inv_rect_Type2 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 **) +let traceinf_inv_rect_Type2 hterm h1 = + let hcut = let Econsinf (x, x0) = Lazy.force hterm in h1 x x0 in hcut __ + +(** val traceinf_inv_rect_Type1 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 **) +let traceinf_inv_rect_Type1 hterm h1 = + let hcut = let Econsinf (x, x0) = Lazy.force hterm in h1 x x0 in hcut __ + +(** val traceinf_inv_rect_Type0 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 **) +let traceinf_inv_rect_Type0 hterm h1 = + let hcut = let Econsinf (x, x0) = Lazy.force hterm in h1 x x0 in hcut __ + +(** val traceinf_discr : traceinf -> traceinf -> __ **) +let traceinf_discr x y = + Logic.eq_rect_Type2 x + (let Econsinf (a0, a1) = Lazy.force x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val traceinf_jmdiscr : traceinf -> traceinf -> __ **) +let traceinf_jmdiscr x y = + Logic.eq_rect_Type2 x + (let Econsinf (a0, a1) = Lazy.force x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val eappinf : trace -> traceinf -> traceinf **) +let rec eappinf t t0 = + match t with + | List.Nil -> t0 + | List.Cons (ev, t') -> lazy (Econsinf (ev, (eappinf t' t0))) + +(** val remove_costs : trace -> trace **) +let remove_costs = + List.filter (fun e -> + match e with + | EVcost x -> Bool.False + | EVextcall (x, x0, x1) -> Bool.True) + +type traceinf' = __traceinf' Lazy.t +and __traceinf' = +| Econsinf' of trace * traceinf' + +(** val traceinf'_inv_rect_Type4 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 **) +let traceinf'_inv_rect_Type4 hterm h1 = + let hcut = let Econsinf' (x, x0) = Lazy.force hterm in h1 x x0 __ in + hcut __ + +(** val traceinf'_inv_rect_Type3 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 **) +let traceinf'_inv_rect_Type3 hterm h1 = + let hcut = let Econsinf' (x, x0) = Lazy.force hterm in h1 x x0 __ in + hcut __ + +(** val traceinf'_inv_rect_Type2 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 **) +let traceinf'_inv_rect_Type2 hterm h1 = + let hcut = let Econsinf' (x, x0) = Lazy.force hterm in h1 x x0 __ in + hcut __ + +(** val traceinf'_inv_rect_Type1 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 **) +let traceinf'_inv_rect_Type1 hterm h1 = + let hcut = let Econsinf' (x, x0) = Lazy.force hterm in h1 x x0 __ in + hcut __ + +(** val traceinf'_inv_rect_Type0 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 **) +let traceinf'_inv_rect_Type0 hterm h1 = + let hcut = let Econsinf' (x, x0) = Lazy.force hterm in h1 x x0 __ in + hcut __ + +(** val traceinf'_discr : traceinf' -> traceinf' -> __ **) +let traceinf'_discr x y = + Logic.eq_rect_Type2 x + (let Econsinf' (a0, a1) = Lazy.force x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val traceinf'_jmdiscr : traceinf' -> traceinf' -> __ **) +let traceinf'_jmdiscr x y = + Logic.eq_rect_Type2 x + (let Econsinf' (a0, a1) = Lazy.force x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val split_traceinf' : + trace -> traceinf' -> (event, traceinf') Types.prod **) +let split_traceinf' t t0 = + (match t with + | List.Nil -> (fun _ -> Logic.false_rect_Type0 __) + | List.Cons (e, t') -> + (fun _ -> + (match t' with + | List.Nil -> (fun _ -> { Types.fst = e; Types.snd = t0 }) + | List.Cons (e', t'') -> + (fun _ -> { Types.fst = e; Types.snd = (lazy (Econsinf' (t', + t0))) })) __)) __ + +(** val traceinf_of_traceinf' : traceinf' -> traceinf **) +let rec traceinf_of_traceinf' t' = + let Econsinf' (t, t'') = Lazy.force t' in + let { Types.fst = e; Types.snd = tl } = split_traceinf' t t'' in + lazy (Econsinf (e, (traceinf_of_traceinf' tl))) + diff --git a/extracted/events.mli b/extracted/events.mli new file mode 100644 index 0000000..98d5491 --- /dev/null +++ b/extracted/events.mli @@ -0,0 +1,240 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open CostLabel + +type eventval = +| EVint of AST.intsize * AST.bvint + +val eventval_rect_Type4 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 + +val eventval_rect_Type5 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 + +val eventval_rect_Type3 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 + +val eventval_rect_Type2 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 + +val eventval_rect_Type1 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 + +val eventval_rect_Type0 : + (AST.intsize -> AST.bvint -> 'a1) -> eventval -> 'a1 + +val eventval_inv_rect_Type4 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 + +val eventval_inv_rect_Type3 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 + +val eventval_inv_rect_Type2 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 + +val eventval_inv_rect_Type1 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 + +val eventval_inv_rect_Type0 : + eventval -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> 'a1 + +val eventval_discr : eventval -> eventval -> __ + +val eventval_jmdiscr : eventval -> eventval -> __ + +type event = +| EVcost of CostLabel.costlabel +| EVextcall of AST.ident * eventval List.list * eventval + +val event_rect_Type4 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 + +val event_rect_Type5 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 + +val event_rect_Type3 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 + +val event_rect_Type2 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 + +val event_rect_Type1 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 + +val event_rect_Type0 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> eventval List.list -> + eventval -> 'a1) -> event -> 'a1 + +val event_inv_rect_Type4 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 + +val event_inv_rect_Type3 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 + +val event_inv_rect_Type2 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 + +val event_inv_rect_Type1 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 + +val event_inv_rect_Type0 : + event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> eventval + List.list -> eventval -> __ -> 'a1) -> 'a1 + +val event_discr : event -> event -> __ + +val event_jmdiscr : event -> event -> __ + +type trace = event List.list + +val e0 : trace + +val echarge : CostLabel.costlabel -> trace + +val eextcall : AST.ident -> eventval List.list -> eventval -> trace + +val eapp : trace -> trace -> trace + +type traceinf = __traceinf Lazy.t +and __traceinf = +| Econsinf of event * traceinf + +val traceinf_inv_rect_Type4 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 + +val traceinf_inv_rect_Type3 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 + +val traceinf_inv_rect_Type2 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 + +val traceinf_inv_rect_Type1 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 + +val traceinf_inv_rect_Type0 : + traceinf -> (event -> traceinf -> __ -> 'a1) -> 'a1 + +val traceinf_discr : traceinf -> traceinf -> __ + +val traceinf_jmdiscr : traceinf -> traceinf -> __ + +val eappinf : trace -> traceinf -> traceinf + +val remove_costs : trace -> trace + +type traceinf' = __traceinf' Lazy.t +and __traceinf' = +| Econsinf' of trace * traceinf' + +val traceinf'_inv_rect_Type4 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 + +val traceinf'_inv_rect_Type3 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 + +val traceinf'_inv_rect_Type2 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 + +val traceinf'_inv_rect_Type1 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 + +val traceinf'_inv_rect_Type0 : + traceinf' -> (trace -> traceinf' -> __ -> __ -> 'a1) -> 'a1 + +val traceinf'_discr : traceinf' -> traceinf' -> __ + +val traceinf'_jmdiscr : traceinf' -> traceinf' -> __ + +val split_traceinf' : trace -> traceinf' -> (event, traceinf') Types.prod + +val traceinf_of_traceinf' : traceinf' -> traceinf + diff --git a/extracted/executions.ml b/extracted/executions.ml new file mode 100644 index 0000000..3d435a8 --- /dev/null +++ b/extracted/executions.ml @@ -0,0 +1,92 @@ +open Preamble + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open SmallstepExec + +open IO + diff --git a/extracted/executions.mli b/extracted/executions.mli new file mode 100644 index 0000000..3d435a8 --- /dev/null +++ b/extracted/executions.mli @@ -0,0 +1,92 @@ +open Preamble + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open SmallstepExec + +open IO + diff --git a/extracted/exp.ml b/extracted/exp.ml new file mode 100644 index 0000000..2f28f96 --- /dev/null +++ b/extracted/exp.ml @@ -0,0 +1,23 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Div_and_mod + +(** val exp : Nat.nat -> Nat.nat -> Nat.nat **) +let rec exp n = function +| Nat.O -> Nat.S Nat.O +| Nat.S p -> Nat.times (exp n p) n + diff --git a/extracted/exp.mli b/extracted/exp.mli new file mode 100644 index 0000000..bed9b0b --- /dev/null +++ b/extracted/exp.mli @@ -0,0 +1,20 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Div_and_mod + +val exp : Nat.nat -> Nat.nat -> Nat.nat + diff --git a/extracted/extraGlobalenvs.ml b/extracted/extraGlobalenvs.ml new file mode 100644 index 0000000..4a678cd --- /dev/null +++ b/extracted/extraGlobalenvs.ml @@ -0,0 +1,96 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + diff --git a/extracted/extraGlobalenvs.mli b/extracted/extraGlobalenvs.mli new file mode 100644 index 0000000..4a678cd --- /dev/null +++ b/extracted/extraGlobalenvs.mli @@ -0,0 +1,96 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + diff --git a/extracted/extraMonads.ml b/extracted/extraMonads.ml new file mode 100644 index 0000000..b7018bb --- /dev/null +++ b/extracted/extraMonads.ml @@ -0,0 +1,310 @@ +open Preamble + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Proper + +open Div_and_mod + +open Util + +open Extralib + +open IOMonad + +type monadFunctRel = +| Mk_MonadFunctRel + +(** val monadFunctRel_rect_Type4 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 **) +let rec monadFunctRel_rect_Type4 m1 m2 h_mk_MonadFunctRel = function +| Mk_MonadFunctRel -> h_mk_MonadFunctRel __ __ __ __ + +(** val monadFunctRel_rect_Type5 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 **) +let rec monadFunctRel_rect_Type5 m1 m2 h_mk_MonadFunctRel = function +| Mk_MonadFunctRel -> h_mk_MonadFunctRel __ __ __ __ + +(** val monadFunctRel_rect_Type3 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 **) +let rec monadFunctRel_rect_Type3 m1 m2 h_mk_MonadFunctRel = function +| Mk_MonadFunctRel -> h_mk_MonadFunctRel __ __ __ __ + +(** val monadFunctRel_rect_Type2 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 **) +let rec monadFunctRel_rect_Type2 m1 m2 h_mk_MonadFunctRel = function +| Mk_MonadFunctRel -> h_mk_MonadFunctRel __ __ __ __ + +(** val monadFunctRel_rect_Type1 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 **) +let rec monadFunctRel_rect_Type1 m1 m2 h_mk_MonadFunctRel = function +| Mk_MonadFunctRel -> h_mk_MonadFunctRel __ __ __ __ + +(** val monadFunctRel_rect_Type0 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 **) +let rec monadFunctRel_rect_Type0 m1 m2 h_mk_MonadFunctRel = function +| Mk_MonadFunctRel -> h_mk_MonadFunctRel __ __ __ __ + +(** val monadFunctRel_inv_rect_Type4 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let monadFunctRel_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = monadFunctRel_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel_inv_rect_Type3 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let monadFunctRel_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = monadFunctRel_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel_inv_rect_Type2 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let monadFunctRel_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = monadFunctRel_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel_inv_rect_Type1 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let monadFunctRel_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = monadFunctRel_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel_inv_rect_Type0 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let monadFunctRel_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = monadFunctRel_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel_jmdiscr : + Monad.monad -> Monad.monad -> monadFunctRel -> monadFunctRel -> __ **) +let monadFunctRel_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (let Mk_MonadFunctRel = x in Obj.magic (fun _ dH -> dH __ __ __ __)) y + +type monadFunctRel1 = +| Mk_MonadFunctRel1 + +(** val monadFunctRel1_rect_Type4 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 **) +let rec monadFunctRel1_rect_Type4 m1 m2 h_mk_MonadFunctRel1 = function +| Mk_MonadFunctRel1 -> h_mk_MonadFunctRel1 __ __ __ __ __ + +(** val monadFunctRel1_rect_Type5 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 **) +let rec monadFunctRel1_rect_Type5 m1 m2 h_mk_MonadFunctRel1 = function +| Mk_MonadFunctRel1 -> h_mk_MonadFunctRel1 __ __ __ __ __ + +(** val monadFunctRel1_rect_Type3 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 **) +let rec monadFunctRel1_rect_Type3 m1 m2 h_mk_MonadFunctRel1 = function +| Mk_MonadFunctRel1 -> h_mk_MonadFunctRel1 __ __ __ __ __ + +(** val monadFunctRel1_rect_Type2 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 **) +let rec monadFunctRel1_rect_Type2 m1 m2 h_mk_MonadFunctRel1 = function +| Mk_MonadFunctRel1 -> h_mk_MonadFunctRel1 __ __ __ __ __ + +(** val monadFunctRel1_rect_Type1 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 **) +let rec monadFunctRel1_rect_Type1 m1 m2 h_mk_MonadFunctRel1 = function +| Mk_MonadFunctRel1 -> h_mk_MonadFunctRel1 __ __ __ __ __ + +(** val monadFunctRel1_rect_Type0 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 **) +let rec monadFunctRel1_rect_Type0 m1 m2 h_mk_MonadFunctRel1 = function +| Mk_MonadFunctRel1 -> h_mk_MonadFunctRel1 __ __ __ __ __ + +(** val monadFunctRel1_inv_rect_Type4 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let monadFunctRel1_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = monadFunctRel1_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel1_inv_rect_Type3 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let monadFunctRel1_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = monadFunctRel1_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel1_inv_rect_Type2 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let monadFunctRel1_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = monadFunctRel1_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel1_inv_rect_Type1 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let monadFunctRel1_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = monadFunctRel1_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel1_inv_rect_Type0 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let monadFunctRel1_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = monadFunctRel1_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val monadFunctRel1_jmdiscr : + Monad.monad -> Monad.monad -> monadFunctRel1 -> monadFunctRel1 -> __ **) +let monadFunctRel1_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (let Mk_MonadFunctRel1 = x in Obj.magic (fun _ dH -> dH __ __ __ __ __)) + y + +type monadGenRel = +| Mk_MonadGenRel + +(** val monadGenRel_rect_Type4 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 **) +let rec monadGenRel_rect_Type4 m1 m2 h_mk_MonadGenRel = function +| Mk_MonadGenRel -> h_mk_MonadGenRel __ __ __ __ __ + +(** val monadGenRel_rect_Type5 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 **) +let rec monadGenRel_rect_Type5 m1 m2 h_mk_MonadGenRel = function +| Mk_MonadGenRel -> h_mk_MonadGenRel __ __ __ __ __ + +(** val monadGenRel_rect_Type3 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 **) +let rec monadGenRel_rect_Type3 m1 m2 h_mk_MonadGenRel = function +| Mk_MonadGenRel -> h_mk_MonadGenRel __ __ __ __ __ + +(** val monadGenRel_rect_Type2 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 **) +let rec monadGenRel_rect_Type2 m1 m2 h_mk_MonadGenRel = function +| Mk_MonadGenRel -> h_mk_MonadGenRel __ __ __ __ __ + +(** val monadGenRel_rect_Type1 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 **) +let rec monadGenRel_rect_Type1 m1 m2 h_mk_MonadGenRel = function +| Mk_MonadGenRel -> h_mk_MonadGenRel __ __ __ __ __ + +(** val monadGenRel_rect_Type0 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 **) +let rec monadGenRel_rect_Type0 m1 m2 h_mk_MonadGenRel = function +| Mk_MonadGenRel -> h_mk_MonadGenRel __ __ __ __ __ + +(** val monadGenRel_inv_rect_Type4 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let monadGenRel_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = monadGenRel_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val monadGenRel_inv_rect_Type3 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let monadGenRel_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = monadGenRel_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val monadGenRel_inv_rect_Type2 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let monadGenRel_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = monadGenRel_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val monadGenRel_inv_rect_Type1 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let monadGenRel_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = monadGenRel_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val monadGenRel_inv_rect_Type0 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let monadGenRel_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = monadGenRel_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val monadGenRel_jmdiscr : + Monad.monad -> Monad.monad -> monadGenRel -> monadGenRel -> __ **) +let monadGenRel_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (let Mk_MonadGenRel = x in Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val res_preserve : monadFunctRel **) +let res_preserve = + Mk_MonadFunctRel + +(** val res_preserve1 : monadFunctRel1 **) +let res_preserve1 = + Mk_MonadFunctRel1 + +(** val gen_res_preserve : monadGenRel **) +let gen_res_preserve = + Mk_MonadGenRel + +(** val opt_preserve : monadFunctRel **) +let opt_preserve = + Mk_MonadFunctRel + +(** val opt_preserve1 : monadFunctRel1 **) +let opt_preserve1 = + Mk_MonadFunctRel1 + +(** val gen_opt_preserve : monadGenRel **) +let gen_opt_preserve = + Mk_MonadGenRel + +(** val io_preserve : monadFunctRel **) +let io_preserve = + Mk_MonadFunctRel + +(** val io_preserve1 : monadFunctRel1 **) +let io_preserve1 = + Mk_MonadFunctRel1 + +(** val gen_io_preserve : monadGenRel **) +let gen_io_preserve = + Mk_MonadGenRel + diff --git a/extracted/extraMonads.mli b/extracted/extraMonads.mli new file mode 100644 index 0000000..019b470 --- /dev/null +++ b/extracted/extraMonads.mli @@ -0,0 +1,216 @@ +open Preamble + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Proper + +open Div_and_mod + +open Util + +open Extralib + +open IOMonad + +type monadFunctRel = +| Mk_MonadFunctRel + +val monadFunctRel_rect_Type4 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 + +val monadFunctRel_rect_Type5 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 + +val monadFunctRel_rect_Type3 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 + +val monadFunctRel_rect_Type2 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 + +val monadFunctRel_rect_Type1 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 + +val monadFunctRel_rect_Type0 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel -> 'a1 + +val monadFunctRel_inv_rect_Type4 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val monadFunctRel_inv_rect_Type3 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val monadFunctRel_inv_rect_Type2 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val monadFunctRel_inv_rect_Type1 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val monadFunctRel_inv_rect_Type0 : + Monad.monad -> Monad.monad -> monadFunctRel -> (__ -> __ -> __ -> __ -> __ + -> 'a1) -> 'a1 + +val monadFunctRel_jmdiscr : + Monad.monad -> Monad.monad -> monadFunctRel -> monadFunctRel -> __ + +type monadFunctRel1 = +| Mk_MonadFunctRel1 + +val monadFunctRel1_rect_Type4 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 + +val monadFunctRel1_rect_Type5 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 + +val monadFunctRel1_rect_Type3 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 + +val monadFunctRel1_rect_Type2 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 + +val monadFunctRel1_rect_Type1 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 + +val monadFunctRel1_rect_Type0 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadFunctRel1 -> 'a1 + +val monadFunctRel1_inv_rect_Type4 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val monadFunctRel1_inv_rect_Type3 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val monadFunctRel1_inv_rect_Type2 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val monadFunctRel1_inv_rect_Type1 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val monadFunctRel1_inv_rect_Type0 : + Monad.monad -> Monad.monad -> monadFunctRel1 -> (__ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val monadFunctRel1_jmdiscr : + Monad.monad -> Monad.monad -> monadFunctRel1 -> monadFunctRel1 -> __ + +type monadGenRel = +| Mk_MonadGenRel + +val monadGenRel_rect_Type4 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 + +val monadGenRel_rect_Type5 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 + +val monadGenRel_rect_Type3 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 + +val monadGenRel_rect_Type2 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 + +val monadGenRel_rect_Type1 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 + +val monadGenRel_rect_Type0 : + Monad.monad -> Monad.monad -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> + monadGenRel -> 'a1 + +val monadGenRel_inv_rect_Type4 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val monadGenRel_inv_rect_Type3 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val monadGenRel_inv_rect_Type2 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val monadGenRel_inv_rect_Type1 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val monadGenRel_inv_rect_Type0 : + Monad.monad -> Monad.monad -> monadGenRel -> (__ -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val monadGenRel_jmdiscr : + Monad.monad -> Monad.monad -> monadGenRel -> monadGenRel -> __ + +val res_preserve : monadFunctRel + +val res_preserve1 : monadFunctRel1 + +val gen_res_preserve : monadGenRel + +val opt_preserve : monadFunctRel + +val opt_preserve1 : monadFunctRel1 + +val gen_opt_preserve : monadGenRel + +val io_preserve : monadFunctRel + +val io_preserve1 : monadFunctRel1 + +val gen_io_preserve : monadGenRel + diff --git a/extracted/extra_bool.ml b/extracted/extra_bool.ml new file mode 100644 index 0000000..1237ca6 --- /dev/null +++ b/extracted/extra_bool.ml @@ -0,0 +1,35 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Bool + +open Div_and_mod + +open Jmeq + +open Russell + +open Nat + +open Types + +open List + +open Util + +(** val if_elim : + Bool.bool -> 'a1 -> 'a1 -> (__ -> 'a2) -> (__ -> 'a2) -> 'a2 **) +let if_elim clearme e1 e2 x x0 = + (match clearme with + | Bool.True -> (fun e3 e4 _ auto auto' -> auto __) + | Bool.False -> (fun e3 e4 _ auto auto' -> auto' __)) e1 e2 __ x x0 + diff --git a/extracted/extra_bool.mli b/extracted/extra_bool.mli new file mode 100644 index 0000000..ea26c48 --- /dev/null +++ b/extracted/extra_bool.mli @@ -0,0 +1,30 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Bool + +open Div_and_mod + +open Jmeq + +open Russell + +open Nat + +open Types + +open List + +open Util + +val if_elim : Bool.bool -> 'a1 -> 'a1 -> (__ -> 'a2) -> (__ -> 'a2) -> 'a2 + diff --git a/extracted/extralib.ml b/extracted/extralib.ml new file mode 100644 index 0000000..25bea63 --- /dev/null +++ b/extracted/extralib.ml @@ -0,0 +1,74 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +(** val eq_rect_Type0_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type0_r a p x0 = + Logic.eq_rect_r a x0 p + +(** val eq_rect_r2 : 'a1 -> 'a1 -> 'a2 -> 'a2 **) +let eq_rect_r2 a x x0 = + (fun _ h -> h) __ x0 + +(** val eq_rect_Type2_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type2_r a p x0 = + eq_rect_r2 a x0 p + +(** val dec_bounded_forall : + (Nat.nat -> (__, __) Types.sum) -> Nat.nat -> (__, __) Types.sum **) +let dec_bounded_forall hP_dec k = + Nat.nat_rect_Type0 (Types.Inl __) (fun k0 hind -> + match hind with + | Types.Inl _ -> + (match hP_dec k0 with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __) k + +(** val dec_bounded_exists : + (Nat.nat -> (__, __) Types.sum) -> Nat.nat -> (__, __) Types.sum **) +let dec_bounded_exists hP_dec k = + Nat.nat_rect_Type0 (Types.Inr __) (fun k0 hind -> + match hind with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> + (match hP_dec k0 with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __)) k + +(** val dec_true : (__, __) Types.sum -> (__ -> 'a1) -> 'a1 **) +let dec_true f h = + match f with + | Types.Inl x -> h x + | Types.Inr _ -> assert false (* absurd case *) + +(** val dec_false : (__, __) Types.sum -> (__ -> 'a1) -> 'a1 **) +let dec_false f h = + match f with + | Types.Inl _ -> assert false (* absurd case *) + | Types.Inr x -> h x + diff --git a/extracted/extralib.mli b/extracted/extralib.mli new file mode 100644 index 0000000..17f39c4 --- /dev/null +++ b/extracted/extralib.mli @@ -0,0 +1,44 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +val eq_rect_Type0_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_r2 : 'a1 -> 'a1 -> 'a2 -> 'a2 + +val eq_rect_Type2_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val dec_bounded_forall : + (Nat.nat -> (__, __) Types.sum) -> Nat.nat -> (__, __) Types.sum + +val dec_bounded_exists : + (Nat.nat -> (__, __) Types.sum) -> Nat.nat -> (__, __) Types.sum + +val dec_true : (__, __) Types.sum -> (__ -> 'a1) -> 'a1 + +val dec_false : (__, __) Types.sum -> (__ -> 'a1) -> 'a1 + diff --git a/extracted/extranat.ml b/extracted/extranat.ml new file mode 100644 index 0000000..b1ed046 --- /dev/null +++ b/extracted/extranat.ml @@ -0,0 +1,180 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +(** val nat_bound_opt : Nat.nat -> Nat.nat -> __ Types.option **) +let rec nat_bound_opt n n0 = + match n with + | Nat.O -> Types.None + | Nat.S n' -> + (match n0 with + | Nat.O -> Obj.magic (Monad.m_return0 (Monad.max_def Option.option) __) + | Nat.S n'0 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Option.option) + (Obj.magic (nat_bound_opt n' n'0)) (fun _ -> + Monad.m_return0 (Monad.max_def Option.option) __))) + +type nat_compared = +| Nat_lt of Nat.nat * Nat.nat +| Nat_eq of Nat.nat +| Nat_gt of Nat.nat * Nat.nat + +(** val nat_compared_rect_Type4 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 **) +let rec nat_compared_rect_Type4 h_nat_lt h_nat_eq h_nat_gt x_1125 x_1124 = function +| Nat_lt (n, m) -> h_nat_lt n m +| Nat_eq n -> h_nat_eq n +| Nat_gt (n, m) -> h_nat_gt n m + +(** val nat_compared_rect_Type5 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 **) +let rec nat_compared_rect_Type5 h_nat_lt h_nat_eq h_nat_gt x_1131 x_1130 = function +| Nat_lt (n, m) -> h_nat_lt n m +| Nat_eq n -> h_nat_eq n +| Nat_gt (n, m) -> h_nat_gt n m + +(** val nat_compared_rect_Type3 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 **) +let rec nat_compared_rect_Type3 h_nat_lt h_nat_eq h_nat_gt x_1137 x_1136 = function +| Nat_lt (n, m) -> h_nat_lt n m +| Nat_eq n -> h_nat_eq n +| Nat_gt (n, m) -> h_nat_gt n m + +(** val nat_compared_rect_Type2 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 **) +let rec nat_compared_rect_Type2 h_nat_lt h_nat_eq h_nat_gt x_1143 x_1142 = function +| Nat_lt (n, m) -> h_nat_lt n m +| Nat_eq n -> h_nat_eq n +| Nat_gt (n, m) -> h_nat_gt n m + +(** val nat_compared_rect_Type1 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 **) +let rec nat_compared_rect_Type1 h_nat_lt h_nat_eq h_nat_gt x_1149 x_1148 = function +| Nat_lt (n, m) -> h_nat_lt n m +| Nat_eq n -> h_nat_eq n +| Nat_gt (n, m) -> h_nat_gt n m + +(** val nat_compared_rect_Type0 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 **) +let rec nat_compared_rect_Type0 h_nat_lt h_nat_eq h_nat_gt x_1155 x_1154 = function +| Nat_lt (n, m) -> h_nat_lt n m +| Nat_eq n -> h_nat_eq n +| Nat_gt (n, m) -> h_nat_gt n m + +(** val nat_compared_inv_rect_Type4 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> + __ -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat + -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let nat_compared_inv_rect_Type4 x1 x2 hterm h1 h2 h3 = + let hcut = nat_compared_rect_Type4 h1 h2 h3 x1 x2 hterm in hcut __ __ __ + +(** val nat_compared_inv_rect_Type3 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> + __ -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat + -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let nat_compared_inv_rect_Type3 x1 x2 hterm h1 h2 h3 = + let hcut = nat_compared_rect_Type3 h1 h2 h3 x1 x2 hterm in hcut __ __ __ + +(** val nat_compared_inv_rect_Type2 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> + __ -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat + -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let nat_compared_inv_rect_Type2 x1 x2 hterm h1 h2 h3 = + let hcut = nat_compared_rect_Type2 h1 h2 h3 x1 x2 hterm in hcut __ __ __ + +(** val nat_compared_inv_rect_Type1 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> + __ -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat + -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let nat_compared_inv_rect_Type1 x1 x2 hterm h1 h2 h3 = + let hcut = nat_compared_rect_Type1 h1 h2 h3 x1 x2 hterm in hcut __ __ __ + +(** val nat_compared_inv_rect_Type0 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> + __ -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat + -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let nat_compared_inv_rect_Type0 x1 x2 hterm h1 h2 h3 = + let hcut = nat_compared_rect_Type0 h1 h2 h3 x1 x2 hterm in hcut __ __ __ + +(** val nat_compared_discr : + Nat.nat -> Nat.nat -> nat_compared -> nat_compared -> __ **) +let nat_compared_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Nat_lt (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Nat_eq a0 -> Obj.magic (fun _ dH -> dH __) + | Nat_gt (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val nat_compared_jmdiscr : + Nat.nat -> Nat.nat -> nat_compared -> nat_compared -> __ **) +let nat_compared_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Nat_lt (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Nat_eq a0 -> Obj.magic (fun _ dH -> dH __) + | Nat_gt (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val nat_compare : Nat.nat -> Nat.nat -> nat_compared **) +let rec nat_compare n m = + match n with + | Nat.O -> + (match m with + | Nat.O -> Nat_eq Nat.O + | Nat.S m' -> Nat_lt (Nat.O, m')) + | Nat.S n' -> + (match m with + | Nat.O -> Nat_gt (n', Nat.O) + | Nat.S m' -> + (match nat_compare n' m' with + | Nat_lt (x, y) -> Nat_lt ((Nat.S x), y) + | Nat_eq x -> Nat_eq (Nat.S x) + | Nat_gt (x, y) -> Nat_gt (x, (Nat.S y)))) + +(** val eq_nat_dec : Nat.nat -> Nat.nat -> (__, __) Types.sum **) +let rec eq_nat_dec n m = + match n with + | Nat.O -> + (match m with + | Nat.O -> Types.Inl __ + | Nat.S m' -> Types.Inr __) + | Nat.S n' -> + (match m with + | Nat.O -> Types.Inr __ + | Nat.S m' -> + (match eq_nat_dec n' m' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __)) + diff --git a/extracted/extranat.mli b/extracted/extranat.mli new file mode 100644 index 0000000..a25e98d --- /dev/null +++ b/extracted/extranat.mli @@ -0,0 +1,96 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +val nat_bound_opt : Nat.nat -> Nat.nat -> __ Types.option + +type nat_compared = +| Nat_lt of Nat.nat * Nat.nat +| Nat_eq of Nat.nat +| Nat_gt of Nat.nat * Nat.nat + +val nat_compared_rect_Type4 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 + +val nat_compared_rect_Type5 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 + +val nat_compared_rect_Type3 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 + +val nat_compared_rect_Type2 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 + +val nat_compared_rect_Type1 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 + +val nat_compared_rect_Type0 : + (Nat.nat -> Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> Nat.nat -> + 'a1) -> Nat.nat -> Nat.nat -> nat_compared -> 'a1 + +val nat_compared_inv_rect_Type4 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> __ + -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val nat_compared_inv_rect_Type3 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> __ + -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val nat_compared_inv_rect_Type2 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> __ + -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val nat_compared_inv_rect_Type1 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> __ + -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val nat_compared_inv_rect_Type0 : + Nat.nat -> Nat.nat -> nat_compared -> (Nat.nat -> Nat.nat -> __ -> __ -> __ + -> 'a1) -> (Nat.nat -> __ -> __ -> __ -> 'a1) -> (Nat.nat -> Nat.nat -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val nat_compared_discr : + Nat.nat -> Nat.nat -> nat_compared -> nat_compared -> __ + +val nat_compared_jmdiscr : + Nat.nat -> Nat.nat -> nat_compared -> nat_compared -> __ + +val nat_compare : Nat.nat -> Nat.nat -> nat_compared + +val eq_nat_dec : Nat.nat -> Nat.nat -> (__, __) Types.sum + diff --git a/extracted/fetch.ml b/extracted/fetch.ml new file mode 100644 index 0000000..4ad7b4f --- /dev/null +++ b/extracted/fetch.ml @@ -0,0 +1,1660 @@ +open Preamble + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open BitVector + +open Arithmetic + +open BitVectorTrie + +open String + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +(** val inefficient_address_of_word_labels_code_mem : + ASM.labelled_instruction List.list -> ASM.identifier -> + BitVector.bitVector **) +let inefficient_address_of_word_labels_code_mem code_mem id = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (LabelledObjects.index_of + (LabelledObjects.instruction_matches_identifier PreIdentifiers.ASMTag + id) code_mem) + +type label_map = Nat.nat Identifiers.identifier_map + +(** val create_label_cost_map0 : + ASM.labelled_instruction List.list -> (label_map, CostLabel.costlabel + BitVectorTrie.bitVectorTrie) Types.prod Types.sig0 **) +let create_label_cost_map0 program = + (Types.pi1 + (FoldStuff.foldl_strong program (fun prefix x tl _ labels_costs_ppc -> + (let { Types.fst = eta28695; Types.snd = ppc } = + Types.pi1 labels_costs_ppc + in + (fun _ -> + (let { Types.fst = labels; Types.snd = costs } = eta28695 in + (fun _ -> + (let { Types.fst = label; Types.snd = instr } = x in + (fun _ -> + let labels1 = + match label with + | Types.None -> labels + | Types.Some l -> Identifiers.add PreIdentifiers.ASMTag labels l ppc + in + let costs1 = + match instr with + | ASM.Instruction x0 -> costs + | ASM.Comment x0 -> costs + | ASM.Cost cost -> + BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) ppc) cost costs + | ASM.Jmp x0 -> costs + | ASM.Jnz (x0, x1, x2) -> costs + | ASM.Call x0 -> costs + | ASM.Mov (x0, x1, x2) -> costs + in + { Types.fst = { Types.fst = labels1; Types.snd = costs1 }; Types.snd = + (Nat.S ppc) })) __)) __)) __) { Types.fst = { Types.fst = + (Identifiers.empty_map PreIdentifiers.ASMTag); Types.snd = + (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) }; Types.snd = Nat.O })).Types.fst + +(** val create_label_cost_map : + ASM.labelled_instruction List.list -> (label_map, CostLabel.costlabel + BitVectorTrie.bitVectorTrie) Types.prod **) +let create_label_cost_map program = + Types.pi1 (create_label_cost_map0 program) + +(** val address_of_word_labels : + ASM.labelled_instruction List.list -> ASM.identifier -> BitVector.word **) +let address_of_word_labels code_mem id = + let labels = (create_label_cost_map code_mem).Types.fst in + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (Identifiers.lookup_def PreIdentifiers.ASMTag labels id Nat.O) + +(** val bitvector_max_nat : Nat.nat -> Nat.nat **) +let bitvector_max_nat length = + Exp.exp (Nat.S (Nat.S Nat.O)) length + +(** val code_memory_size : Nat.nat **) +let code_memory_size = + bitvector_max_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + +(** val prod_inv_rect_Type0 : + ('a1, 'a2) Types.prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let prod_inv_rect_Type0 clearme = + let { Types.fst = fst; Types.snd = snd } = clearme in + (fun auto -> auto fst snd __) + +(** val fetch0 : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + BitVector.byte -> ((ASM.instruction, BitVector.word) Types.prod, Nat.nat) + Types.prod **) +let fetch0 pmem pc v = + let { Types.fst = b; Types.snd = v0 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))) + v + in + (match b with + | Bool.True -> + let { Types.fst = b0; Types.snd = v1 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) v0 + in + (match b0 with + | Bool.True -> + let { Types.fst = b1; Types.snd = v2 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) v1 + in + (match b1 with + | Bool.True -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.MOV + (Types.Inl (Types.Inl (Types.Inl (Types.Inl (Types.Inr + { Types.fst = (ASM.REGISTER v4); Types.snd = + ASM.ACC_A }))))))); Types.snd = pc }; Types.snd = (Nat.S + Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.MOV (Types.Inl (Types.Inl (Types.Inl (Types.Inl + (Types.Inr { Types.fst = (ASM.INDIRECT + (Vector.from_singl v6)); Types.snd = + ASM.ACC_A }))))))); Types.snd = pc }; Types.snd = + (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.DIRECT b10); Types.snd = ASM.ACC_A })))))); + Types.snd = pc0 }; Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.CPL ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.MOVX (Types.Inr { Types.fst = (ASM.EXT_INDIRECT + (Vector.from_singl v6)); Types.snd = ASM.ACC_A }))); + Types.snd = pc }; Types.snd = (Nat.S (Nat.S + Nat.O)) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.MOVX (Types.Inr { Types.fst = + ASM.EXT_INDIRECT_DPTR; Types.snd = + ASM.ACC_A }))); Types.snd = pc }; Types.snd = + (Nat.S (Nat.S Nat.O)) })))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.MOV + (Types.Inl (Types.Inl (Types.Inl (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.REGISTER + v4) }))))))); Types.snd = pc }; Types.snd = (Nat.S + Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.MOV (Types.Inl (Types.Inl (Types.Inl (Types.Inl + (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.INDIRECT (Vector.from_singl v6)) }))))))); + Types.snd = pc }; Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DIRECT + b10) }))))))); Types.snd = pc0 }; Types.snd = + (Nat.S Nat.O) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.CLR ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.MOVX (Types.Inl { Types.fst = ASM.ACC_A; + Types.snd = (ASM.EXT_INDIRECT + (Vector.from_singl v6)) }))); Types.snd = pc }; + Types.snd = (Nat.S (Nat.S Nat.O)) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.MOVX (Types.Inl { Types.fst = ASM.ACC_A; + Types.snd = ASM.EXT_INDIRECT_DPTR }))); + Types.snd = pc }; Types.snd = (Nat.S (Nat.S + Nat.O)) }))))) + | Bool.False -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) (fun pc0 b10 _ -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.DJNZ + ((ASM.REGISTER v4), (ASM.RELATIVE b10)))); Types.snd = + pc0 }; Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.XCHD (ASM.ACC_A, (ASM.INDIRECT + (Vector.from_singl v6))))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.DJNZ ((ASM.DIRECT + b10), (ASM.RELATIVE b20)))); Types.snd = pc1 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.DA ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.SETB ASM.CARRY)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.SETB (ASM.BIT_ADDR + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + Nat.O) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.POP (ASM.DIRECT b10))); + Types.snd = pc0 }; Types.snd = (Nat.S (Nat.S + Nat.O)) }))))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.XCH + (ASM.ACC_A, (ASM.REGISTER v4)))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.XCH (ASM.ACC_A, (ASM.INDIRECT + (Vector.from_singl v6))))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.XCH (ASM.ACC_A, + (ASM.DIRECT b10)))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.SWAP ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.CLR ASM.CARRY)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.CLR (ASM.BIT_ADDR + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + Nat.O) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.PUSH (ASM.DIRECT + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + (Nat.S Nat.O)) }))))))) + | Bool.False -> + let { Types.fst = b1; Types.snd = v2 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) v1 + in + (match b1 with + | Bool.True -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) (fun pc1 b20 _ -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.CJNE ((Types.Inr { Types.fst = (ASM.REGISTER v4); + Types.snd = (ASM.DATA b10) }), (ASM.RELATIVE b20)))); + Types.snd = pc1 }; Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.CJNE ((Types.Inr + { Types.fst = (ASM.INDIRECT + (Vector.from_singl v6)); Types.snd = (ASM.DATA + b10) }), (ASM.RELATIVE b20)))); Types.snd = pc1 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.CJNE ((Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = + (ASM.DIRECT b10) }), (ASM.RELATIVE b20)))); + Types.snd = pc1 }; Types.snd = (Nat.S (Nat.S + Nat.O)) })) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.CJNE ((Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DATA + b10) }), (ASM.RELATIVE b20)))); Types.snd = + pc1 }; Types.snd = (Nat.S (Nat.S Nat.O)) })))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.CPL ASM.CARRY)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.CPL (ASM.BIT_ADDR + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + Nat.O) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ANL (Types.Inr + { Types.fst = ASM.CARRY; Types.snd = + (ASM.N_BIT_ADDR b10) }))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }))))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) (fun pc0 b10 _ -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.MOV + (Types.Inl (Types.Inl (Types.Inl (Types.Inl (Types.Inr + { Types.fst = (ASM.REGISTER v4); Types.snd = (ASM.DIRECT + b10) }))))))); Types.snd = pc0 }; Types.snd = (Nat.S + (Nat.S Nat.O)) }) + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.INDIRECT (Vector.from_singl v6)); Types.snd = + (ASM.DIRECT b10) }))))))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.MUL (ASM.ACC_A, ASM.ACC_B))); Types.snd = pc }; + Types.snd = (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) }) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.INC ASM.DPTR)); Types.snd = pc }; + Types.snd = (Nat.S (Nat.S Nat.O)) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inr { Types.fst = ASM.CARRY; Types.snd = + (ASM.BIT_ADDR b10) })))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ORL (Types.Inr + { Types.fst = ASM.CARRY; Types.snd = + (ASM.N_BIT_ADDR b10) }))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })))))) + | Bool.False -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.SUBB + (ASM.ACC_A, (ASM.REGISTER v4)))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.SUBB (ASM.ACC_A, (ASM.INDIRECT + (Vector.from_singl v6))))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.SUBB (ASM.ACC_A, + (ASM.DIRECT b10)))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.SUBB (ASM.ACC_A, + (ASM.DATA b10)))); Types.snd = pc0 }; Types.snd = + (Nat.S Nat.O) }))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.MOVC (ASM.ACC_A, + ASM.ACC_DPTR)); Types.snd = pc }; Types.snd = + (Nat.S (Nat.S Nat.O)) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inr + { Types.fst = (ASM.BIT_ADDR b10); Types.snd = + ASM.CARRY }))); Types.snd = pc0 }; Types.snd = + (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inr { Types.fst = ASM.DPTR; + Types.snd = (ASM.DATA16 + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) b10 b20)) }))))); + Types.snd = pc1 }; Types.snd = (Nat.S (Nat.S + Nat.O)) })))))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) (fun pc0 b10 _ -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.MOV + (Types.Inl (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.DIRECT b10); Types.snd = (ASM.REGISTER v4) })))))); + Types.snd = pc0 }; Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inr { Types.fst = (ASM.DIRECT + b10); Types.snd = (ASM.INDIRECT + (Vector.from_singl v6)) })))))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.DIRECT b10); Types.snd = (ASM.DIRECT + b20) })))))); Types.snd = pc1 }; Types.snd = + (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.DIV (ASM.ACC_A, ASM.ACC_B))); Types.snd = + pc }; Types.snd = (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) })) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.MOVC (ASM.ACC_A, + ASM.ACC_PC)); Types.snd = pc }; Types.snd = + (Nat.S (Nat.S Nat.O)) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ANL (Types.Inr + { Types.fst = ASM.CARRY; Types.snd = + (ASM.BIT_ADDR b10) }))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.SJMP (ASM.RELATIVE b10)); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })))))))) + | Bool.False -> + let { Types.fst = b0; Types.snd = v1 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) v0 + in + (match b0 with + | Bool.True -> + let { Types.fst = b1; Types.snd = v2 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) v1 + in + (match b1 with + | Bool.True -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) (fun pc0 b10 _ -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.MOV + (Types.Inl (Types.Inl (Types.Inl (Types.Inl (Types.Inr + { Types.fst = (ASM.REGISTER v4); Types.snd = (ASM.DATA + b10) }))))))); Types.snd = pc0 }; Types.snd = (Nat.S + Nat.O) }) + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.INDIRECT (Vector.from_singl v6)); Types.snd = + (ASM.DATA b10) }))))))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.DIRECT b10); Types.snd = (ASM.DATA + b20) })))))); Types.snd = pc1 }; Types.snd = + (Nat.S (Nat.S (Nat.S Nat.O))) })) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DATA + b10) }))))))); Types.snd = pc0 }; Types.snd = + (Nat.S Nat.O) }))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.JMP ASM.ACC_DPTR)); Types.snd = pc }; + Types.snd = (Nat.S (Nat.S Nat.O)) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ORL (Types.Inr + { Types.fst = ASM.CARRY; Types.snd = + (ASM.BIT_ADDR b10) }))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.JNZ (ASM.RELATIVE + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + (Nat.S Nat.O)) }))))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.XRL + (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.REGISTER v4) }))); Types.snd = pc }; Types.snd = + (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.XRL (Types.Inl { Types.fst = ASM.ACC_A; + Types.snd = (ASM.INDIRECT + (Vector.from_singl v6)) }))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.XRL (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DIRECT + b10) }))); Types.snd = pc0 }; Types.snd = (Nat.S + Nat.O) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.XRL (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DATA + b10) }))); Types.snd = pc0 }; Types.snd = (Nat.S + Nat.O) }))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.XRL (Types.Inr + { Types.fst = (ASM.DIRECT b10); Types.snd = + (ASM.DATA b20) }))); Types.snd = pc1 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.XRL (Types.Inr + { Types.fst = (ASM.DIRECT b10); Types.snd = + ASM.ACC_A }))); Types.snd = pc0 }; Types.snd = + (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.JZ (ASM.RELATIVE + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + (Nat.S Nat.O)) })))))) + | Bool.False -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.ANL + (Types.Inl (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.REGISTER v4) })))); Types.snd = pc }; Types.snd = + (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.ANL (Types.Inl (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = (ASM.INDIRECT + (Vector.from_singl v6)) })))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ANL (Types.Inl + (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.DIRECT b10) })))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ANL (Types.Inl + (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.DATA b10) })))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ANL (Types.Inl + (Types.Inr { Types.fst = (ASM.DIRECT b10); + Types.snd = (ASM.DATA b20) })))); Types.snd = + pc1 }; Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ANL (Types.Inl + (Types.Inr { Types.fst = (ASM.DIRECT b10); + Types.snd = ASM.ACC_A })))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.JNC (ASM.RELATIVE + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + (Nat.S Nat.O)) }))))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.ORL + (Types.Inl (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.REGISTER v4) })))); Types.snd = pc }; Types.snd = + (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.ORL (Types.Inl (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = (ASM.INDIRECT + (Vector.from_singl v6)) })))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ORL (Types.Inl + (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.DIRECT b10) })))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ORL (Types.Inl + (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.DATA b10) })))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ORL (Types.Inl + (Types.Inr { Types.fst = (ASM.DIRECT b10); + Types.snd = (ASM.DATA b20) })))); Types.snd = + pc1 }; Types.snd = (Nat.S (Nat.S Nat.O)) })) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ORL (Types.Inl + (Types.Inr { Types.fst = (ASM.DIRECT b10); + Types.snd = ASM.ACC_A })))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.JC (ASM.RELATIVE + b10))); Types.snd = pc0 }; Types.snd = (Nat.S + (Nat.S Nat.O)) }))))))) + | Bool.False -> + let { Types.fst = b1; Types.snd = v2 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) v1 + in + (match b1 with + | Bool.True -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.ADDC + (ASM.ACC_A, (ASM.REGISTER v4)))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.ADDC (ASM.ACC_A, (ASM.INDIRECT + (Vector.from_singl v6))))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ADDC (ASM.ACC_A, + (ASM.DIRECT b10)))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ADDC (ASM.ACC_A, + (ASM.DATA b10)))); Types.snd = pc0 }; Types.snd = + (Nat.S Nat.O) }))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.RLC ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + ASM.RETI); Types.snd = pc }; Types.snd = (Nat.S + (Nat.S Nat.O)) }) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.JNB ((ASM.BIT_ADDR + b10), (ASM.RELATIVE b20)))); Types.snd = pc1 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })))))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.ADD + (ASM.ACC_A, (ASM.REGISTER v4)))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.ADD (ASM.ACC_A, (ASM.INDIRECT + (Vector.from_singl v6))))); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ADD (ASM.ACC_A, + (ASM.DIRECT b10)))); Types.snd = pc0 }; + Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.ADD (ASM.ACC_A, + (ASM.DATA b10)))); Types.snd = pc0 }; Types.snd = + (Nat.S Nat.O) }))) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.RL ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + ASM.RET); Types.snd = pc }; Types.snd = (Nat.S + (Nat.S Nat.O)) }) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.JB ((ASM.BIT_ADDR + b10), (ASM.RELATIVE b20)))); Types.snd = pc1 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }))))))) + | Bool.False -> + let { Types.fst = b2; Types.snd = v3 } = + Vector.head (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) v2 + in + (match b2 with + | Bool.True -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.DEC + (ASM.REGISTER v4))); Types.snd = pc }; Types.snd = (Nat.S + Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.DEC (ASM.INDIRECT (Vector.from_singl v6)))); + Types.snd = pc }; Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.DEC (ASM.DIRECT b10))); + Types.snd = pc0 }; Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.DEC ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.RRC ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.LCALL (ASM.ADDR16 + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) b10 b20))); + Types.snd = pc1 }; Types.snd = (Nat.S (Nat.S + Nat.O)) }))) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.ACALL (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.JBC ((ASM.BIT_ADDR + b10), (ASM.RELATIVE b20)))); Types.snd = pc1 }; + Types.snd = (Nat.S (Nat.S Nat.O)) })))))) + | Bool.False -> + let { Types.fst = b3; Types.snd = v4 } = + Vector.head (Nat.S (Nat.S (Nat.S Nat.O))) v3 + in + (match b3 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction (ASM.INC + (ASM.REGISTER v4))); Types.snd = pc }; Types.snd = (Nat.S + Nat.O) } + | Bool.False -> + let { Types.fst = b4; Types.snd = v5 } = + Vector.head (Nat.S (Nat.S Nat.O)) v4 + in + (match b4 with + | Bool.True -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.INC (ASM.INDIRECT (Vector.from_singl v6)))); + Types.snd = pc }; Types.snd = (Nat.S Nat.O) } + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.RealInstruction (ASM.INC (ASM.DIRECT b10))); + Types.snd = pc0 }; Types.snd = (Nat.S Nat.O) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.INC ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) })) + | Bool.False -> + let { Types.fst = b5; Types.snd = v6 } = + Vector.head (Nat.S Nat.O) v5 + in + (match b5 with + | Bool.True -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + { Types.fst = { Types.fst = (ASM.RealInstruction + (ASM.RR ASM.ACC_A)); Types.snd = pc }; + Types.snd = (Nat.S Nat.O) } + | Bool.False -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> + prod_inv_rect_Type0 (ASM.next pmem pc0) + (fun pc1 b20 _ -> { Types.fst = { Types.fst = + (ASM.LJMP (ASM.ADDR16 + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) b10 b20))); + Types.snd = pc1 }; Types.snd = (Nat.S (Nat.S + Nat.O)) }))) + | Bool.False -> + let { Types.fst = b6; Types.snd = v7 } = + Vector.head Nat.O v6 + in + (match b6 with + | Bool.True -> + prod_inv_rect_Type0 (ASM.next pmem pc) + (fun pc0 b10 _ -> { Types.fst = { Types.fst = + (ASM.AJMP (ASM.ADDR11 + (Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) b10))); Types.snd = pc0 }; + Types.snd = (Nat.S (Nat.S Nat.O)) }) + | Bool.False -> + { Types.fst = { Types.fst = (ASM.RealInstruction + ASM.NOP); Types.snd = pc }; Types.snd = (Nat.S + Nat.O) })))))))) + +(** val fetch : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + ((ASM.instruction, BitVector.word) Types.prod, Nat.nat) Types.prod **) +let fetch pmem pc = + let { Types.fst = word; Types.snd = byte } = ASM.next pmem pc in + fetch0 pmem word byte + diff --git a/extracted/fetch.mli b/extracted/fetch.mli new file mode 100644 index 0000000..bad649d --- /dev/null +++ b/extracted/fetch.mli @@ -0,0 +1,112 @@ +open Preamble + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open BitVector + +open Arithmetic + +open BitVectorTrie + +open String + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +val inefficient_address_of_word_labels_code_mem : + ASM.labelled_instruction List.list -> ASM.identifier -> BitVector.bitVector + +type label_map = Nat.nat Identifiers.identifier_map + +val create_label_cost_map0 : + ASM.labelled_instruction List.list -> (label_map, CostLabel.costlabel + BitVectorTrie.bitVectorTrie) Types.prod Types.sig0 + +val create_label_cost_map : + ASM.labelled_instruction List.list -> (label_map, CostLabel.costlabel + BitVectorTrie.bitVectorTrie) Types.prod + +val address_of_word_labels : + ASM.labelled_instruction List.list -> ASM.identifier -> BitVector.word + +val bitvector_max_nat : Nat.nat -> Nat.nat + +val code_memory_size : Nat.nat + +val prod_inv_rect_Type0 : + ('a1, 'a2) Types.prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val fetch0 : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + BitVector.byte -> ((ASM.instruction, BitVector.word) Types.prod, Nat.nat) + Types.prod + +val fetch : + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.word -> + ((ASM.instruction, BitVector.word) Types.prod, Nat.nat) Types.prod + diff --git a/extracted/fixpoints.ml b/extracted/fixpoints.ml new file mode 100644 index 0000000..4f6ed52 --- /dev/null +++ b/extracted/fixpoints.ml @@ -0,0 +1,322 @@ +open Preamble + +open Exp + +open Arithmetic + +open Integers + +open AST + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open BitVectorTrie + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Graphs + +type property_lattice = { l_bottom : __; l_equal : (__ -> __ -> Bool.bool); + l_included : (__ -> __ -> Bool.bool); + l_is_maximal : (__ -> Bool.bool) } + +(** val property_lattice_rect_Type4 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 **) +let rec property_lattice_rect_Type4 h_mk_property_lattice x_18885 = + let { l_bottom = l_bottom0; l_equal = l_equal0; l_included = l_included0; + l_is_maximal = l_is_maximal0 } = x_18885 + in + h_mk_property_lattice __ l_bottom0 l_equal0 l_included0 l_is_maximal0 + +(** val property_lattice_rect_Type5 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 **) +let rec property_lattice_rect_Type5 h_mk_property_lattice x_18887 = + let { l_bottom = l_bottom0; l_equal = l_equal0; l_included = l_included0; + l_is_maximal = l_is_maximal0 } = x_18887 + in + h_mk_property_lattice __ l_bottom0 l_equal0 l_included0 l_is_maximal0 + +(** val property_lattice_rect_Type3 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 **) +let rec property_lattice_rect_Type3 h_mk_property_lattice x_18889 = + let { l_bottom = l_bottom0; l_equal = l_equal0; l_included = l_included0; + l_is_maximal = l_is_maximal0 } = x_18889 + in + h_mk_property_lattice __ l_bottom0 l_equal0 l_included0 l_is_maximal0 + +(** val property_lattice_rect_Type2 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 **) +let rec property_lattice_rect_Type2 h_mk_property_lattice x_18891 = + let { l_bottom = l_bottom0; l_equal = l_equal0; l_included = l_included0; + l_is_maximal = l_is_maximal0 } = x_18891 + in + h_mk_property_lattice __ l_bottom0 l_equal0 l_included0 l_is_maximal0 + +(** val property_lattice_rect_Type1 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 **) +let rec property_lattice_rect_Type1 h_mk_property_lattice x_18893 = + let { l_bottom = l_bottom0; l_equal = l_equal0; l_included = l_included0; + l_is_maximal = l_is_maximal0 } = x_18893 + in + h_mk_property_lattice __ l_bottom0 l_equal0 l_included0 l_is_maximal0 + +(** val property_lattice_rect_Type0 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 **) +let rec property_lattice_rect_Type0 h_mk_property_lattice x_18895 = + let { l_bottom = l_bottom0; l_equal = l_equal0; l_included = l_included0; + l_is_maximal = l_is_maximal0 } = x_18895 + in + h_mk_property_lattice __ l_bottom0 l_equal0 l_included0 l_is_maximal0 + +type l_property = __ + +(** val l_bottom : property_lattice -> __ **) +let rec l_bottom xxx = + xxx.l_bottom + +(** val l_equal : property_lattice -> __ -> __ -> Bool.bool **) +let rec l_equal xxx = + xxx.l_equal + +(** val l_included : property_lattice -> __ -> __ -> Bool.bool **) +let rec l_included xxx = + xxx.l_included + +(** val l_is_maximal : property_lattice -> __ -> Bool.bool **) +let rec l_is_maximal xxx = + xxx.l_is_maximal + +(** val property_lattice_inv_rect_Type4 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 **) +let property_lattice_inv_rect_Type4 hterm h1 = + let hcut = property_lattice_rect_Type4 h1 hterm in hcut __ + +(** val property_lattice_inv_rect_Type3 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 **) +let property_lattice_inv_rect_Type3 hterm h1 = + let hcut = property_lattice_rect_Type3 h1 hterm in hcut __ + +(** val property_lattice_inv_rect_Type2 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 **) +let property_lattice_inv_rect_Type2 hterm h1 = + let hcut = property_lattice_rect_Type2 h1 hterm in hcut __ + +(** val property_lattice_inv_rect_Type1 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 **) +let property_lattice_inv_rect_Type1 hterm h1 = + let hcut = property_lattice_rect_Type1 h1 hterm in hcut __ + +(** val property_lattice_inv_rect_Type0 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 **) +let property_lattice_inv_rect_Type0 hterm h1 = + let hcut = property_lattice_rect_Type0 h1 hterm in hcut __ + +(** val property_lattice_jmdiscr : + property_lattice -> property_lattice -> __ **) +let property_lattice_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { l_bottom = a1; l_equal = a2; l_included = a3; l_is_maximal = + a4 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +type valuation = Graphs.label -> __ + +type rhs = valuation -> __ + +type equations = Graphs.label -> rhs + +type fixpoint = + valuation + (* singleton inductive, whose constructor was mk_fixpoint *) + +(** val fixpoint_rect_Type4 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 **) +let rec fixpoint_rect_Type4 latt eqs h_mk_fixpoint x_18916 = + let fix_lfp = x_18916 in h_mk_fixpoint fix_lfp __ + +(** val fixpoint_rect_Type5 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 **) +let rec fixpoint_rect_Type5 latt eqs h_mk_fixpoint x_18918 = + let fix_lfp = x_18918 in h_mk_fixpoint fix_lfp __ + +(** val fixpoint_rect_Type3 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 **) +let rec fixpoint_rect_Type3 latt eqs h_mk_fixpoint x_18920 = + let fix_lfp = x_18920 in h_mk_fixpoint fix_lfp __ + +(** val fixpoint_rect_Type2 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 **) +let rec fixpoint_rect_Type2 latt eqs h_mk_fixpoint x_18922 = + let fix_lfp = x_18922 in h_mk_fixpoint fix_lfp __ + +(** val fixpoint_rect_Type1 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 **) +let rec fixpoint_rect_Type1 latt eqs h_mk_fixpoint x_18924 = + let fix_lfp = x_18924 in h_mk_fixpoint fix_lfp __ + +(** val fixpoint_rect_Type0 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 **) +let rec fixpoint_rect_Type0 latt eqs h_mk_fixpoint x_18926 = + let fix_lfp = x_18926 in h_mk_fixpoint fix_lfp __ + +(** val fix_lfp : property_lattice -> equations -> fixpoint -> valuation **) +let rec fix_lfp latt eqs xxx = + let yyy = xxx in yyy + +(** val fixpoint_inv_rect_Type4 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> + 'a1) -> 'a1 **) +let fixpoint_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = fixpoint_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val fixpoint_inv_rect_Type3 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> + 'a1) -> 'a1 **) +let fixpoint_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = fixpoint_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val fixpoint_inv_rect_Type2 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> + 'a1) -> 'a1 **) +let fixpoint_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = fixpoint_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val fixpoint_inv_rect_Type1 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> + 'a1) -> 'a1 **) +let fixpoint_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = fixpoint_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val fixpoint_inv_rect_Type0 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> + 'a1) -> 'a1 **) +let fixpoint_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = fixpoint_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val fixpoint_discr : + property_lattice -> equations -> fixpoint -> fixpoint -> __ **) +let fixpoint_discr a1 a2 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val fixpoint_jmdiscr : + property_lattice -> equations -> fixpoint -> fixpoint -> __ **) +let fixpoint_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val dpi1__o__fix_lfp__o__inject : + property_lattice -> equations -> (fixpoint, 'a1) Types.dPair -> valuation + Types.sig0 **) +let dpi1__o__fix_lfp__o__inject x0 x2 x4 = + fix_lfp x0 x2 x4.Types.dpi1 + +(** val eject__o__fix_lfp__o__inject : + property_lattice -> equations -> fixpoint Types.sig0 -> valuation + Types.sig0 **) +let eject__o__fix_lfp__o__inject x0 x2 x4 = + fix_lfp x0 x2 (Types.pi1 x4) + +(** val fix_lfp__o__inject : + property_lattice -> equations -> fixpoint -> valuation Types.sig0 **) +let fix_lfp__o__inject x0 x2 x3 = + fix_lfp x0 x2 x3 + +(** val dpi1__o__fix_lfp : + property_lattice -> equations -> (fixpoint, 'a1) Types.dPair -> valuation **) +let dpi1__o__fix_lfp x0 x1 x3 = + fix_lfp x0 x1 x3.Types.dpi1 + +(** val eject__o__fix_lfp : + property_lattice -> equations -> fixpoint Types.sig0 -> valuation **) +let eject__o__fix_lfp x0 x1 x3 = + fix_lfp x0 x1 (Types.pi1 x3) + +type fixpoint_computer = property_lattice -> equations -> fixpoint + +(** val dpi1__o__apply_fixpoint : + property_lattice -> equations -> (fixpoint, 'a1) Types.dPair -> + Graphs.label -> __ **) +let dpi1__o__apply_fixpoint x0 x1 x3 = + let latt = x0 in + let eqs = x1 in let f = x3.Types.dpi1 in (fun l -> fix_lfp latt eqs f l) + +(** val eject__o__apply_fixpoint : + property_lattice -> equations -> fixpoint Types.sig0 -> Graphs.label -> + __ **) +let eject__o__apply_fixpoint x0 x1 x3 = + let latt = x0 in + let eqs = x1 in let f = Types.pi1 x3 in (fun l -> fix_lfp latt eqs f l) + diff --git a/extracted/fixpoints.mli b/extracted/fixpoints.mli new file mode 100644 index 0000000..08369d2 --- /dev/null +++ b/extracted/fixpoints.mli @@ -0,0 +1,222 @@ +open Preamble + +open Exp + +open Arithmetic + +open Integers + +open AST + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open BitVectorTrie + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Graphs + +type property_lattice = { l_bottom : __; l_equal : (__ -> __ -> Bool.bool); + l_included : (__ -> __ -> Bool.bool); + l_is_maximal : (__ -> Bool.bool) } + +val property_lattice_rect_Type4 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 + +val property_lattice_rect_Type5 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 + +val property_lattice_rect_Type3 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 + +val property_lattice_rect_Type2 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 + +val property_lattice_rect_Type1 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 + +val property_lattice_rect_Type0 : + (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> Bool.bool) -> (__ -> + Bool.bool) -> 'a1) -> property_lattice -> 'a1 + +type l_property + +val l_bottom : property_lattice -> __ + +val l_equal : property_lattice -> __ -> __ -> Bool.bool + +val l_included : property_lattice -> __ -> __ -> Bool.bool + +val l_is_maximal : property_lattice -> __ -> Bool.bool + +val property_lattice_inv_rect_Type4 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 + +val property_lattice_inv_rect_Type3 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 + +val property_lattice_inv_rect_Type2 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 + +val property_lattice_inv_rect_Type1 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 + +val property_lattice_inv_rect_Type0 : + property_lattice -> (__ -> __ -> (__ -> __ -> Bool.bool) -> (__ -> __ -> + Bool.bool) -> (__ -> Bool.bool) -> __ -> 'a1) -> 'a1 + +val property_lattice_jmdiscr : property_lattice -> property_lattice -> __ + +type valuation = Graphs.label -> __ + +type rhs = valuation -> __ + +type equations = Graphs.label -> rhs + +type fixpoint = + valuation + (* singleton inductive, whose constructor was mk_fixpoint *) + +val fixpoint_rect_Type4 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 + +val fixpoint_rect_Type5 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 + +val fixpoint_rect_Type3 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 + +val fixpoint_rect_Type2 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 + +val fixpoint_rect_Type1 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 + +val fixpoint_rect_Type0 : + property_lattice -> equations -> (valuation -> __ -> 'a1) -> fixpoint -> + 'a1 + +val fix_lfp : property_lattice -> equations -> fixpoint -> valuation + +val fixpoint_inv_rect_Type4 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> 'a1) + -> 'a1 + +val fixpoint_inv_rect_Type3 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> 'a1) + -> 'a1 + +val fixpoint_inv_rect_Type2 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> 'a1) + -> 'a1 + +val fixpoint_inv_rect_Type1 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> 'a1) + -> 'a1 + +val fixpoint_inv_rect_Type0 : + property_lattice -> equations -> fixpoint -> (valuation -> __ -> __ -> 'a1) + -> 'a1 + +val fixpoint_discr : + property_lattice -> equations -> fixpoint -> fixpoint -> __ + +val fixpoint_jmdiscr : + property_lattice -> equations -> fixpoint -> fixpoint -> __ + +val dpi1__o__fix_lfp__o__inject : + property_lattice -> equations -> (fixpoint, 'a1) Types.dPair -> valuation + Types.sig0 + +val eject__o__fix_lfp__o__inject : + property_lattice -> equations -> fixpoint Types.sig0 -> valuation + Types.sig0 + +val fix_lfp__o__inject : + property_lattice -> equations -> fixpoint -> valuation Types.sig0 + +val dpi1__o__fix_lfp : + property_lattice -> equations -> (fixpoint, 'a1) Types.dPair -> valuation + +val eject__o__fix_lfp : + property_lattice -> equations -> fixpoint Types.sig0 -> valuation + +type fixpoint_computer = property_lattice -> equations -> fixpoint + +val dpi1__o__apply_fixpoint : + property_lattice -> equations -> (fixpoint, 'a1) Types.dPair -> + Graphs.label -> __ + +val eject__o__apply_fixpoint : + property_lattice -> equations -> fixpoint Types.sig0 -> Graphs.label -> __ + diff --git a/extracted/foldStuff.ml b/extracted/foldStuff.ml new file mode 100644 index 0000000..cd6e69c --- /dev/null +++ b/extracted/foldStuff.ml @@ -0,0 +1,66 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +(** val foldl_strong_internal : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a1 List.list -> 'a1 List.list -> 'a2 -> 'a2 **) +let rec foldl_strong_internal l h prefix suffix acc = + (match suffix with + | List.Nil -> + (fun _ -> Util.eq_rect_Type0_r prefix acc (List.append prefix List.Nil)) + | List.Cons (hd, tl) -> + (fun _ -> + Logic.eq_coerc + (foldl_strong_internal l h + (List.append prefix (List.Cons (hd, List.Nil))) tl + (h prefix hd tl __ acc)))) __ + +(** val foldl_strong : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a2 -> 'a2 **) +let foldl_strong l h acc = + foldl_strong_internal l h List.Nil l acc + +(** val foldr_strong_internal : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a1 List.list -> 'a1 List.list -> 'a2 -> 'a2 **) +let rec foldr_strong_internal l h prefix suffix acc = + (match suffix with + | List.Nil -> (fun _ -> acc) + | List.Cons (hd, tl) -> + (fun _ -> + h prefix hd tl __ + (foldr_strong_internal l h + (List.append prefix (List.Cons (hd, List.Nil))) tl acc))) __ + +(** val foldr_strong : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a2 -> 'a2 **) +let foldr_strong l h acc = + foldr_strong_internal l h List.Nil l acc + diff --git a/extracted/foldStuff.mli b/extracted/foldStuff.mli new file mode 100644 index 0000000..cda8881 --- /dev/null +++ b/extracted/foldStuff.mli @@ -0,0 +1,44 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +val foldl_strong_internal : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a1 List.list -> 'a1 List.list -> 'a2 -> 'a2 + +val foldl_strong : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a2 -> 'a2 + +val foldr_strong_internal : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a1 List.list -> 'a1 List.list -> 'a2 -> 'a2 + +val foldr_strong : + 'a1 List.list -> ('a1 List.list -> 'a1 -> 'a1 List.list -> __ -> 'a2 -> + 'a2) -> 'a2 -> 'a2 + diff --git a/extracted/fresh.ml b/extracted/fresh.ml new file mode 100644 index 0000000..c61a110 --- /dev/null +++ b/extracted/fresh.ml @@ -0,0 +1,121 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +(** val max_id : AST.ident -> AST.ident -> AST.ident **) +let max_id a b = + let a0 = a in let b0 = b in Positive.max a0 b0 + +(** val max_id_of_env : + (AST.ident, Csyntax.type0) Types.prod List.list -> AST.ident **) +let max_id_of_env = + List.foldr (fun it id -> max_id it.Types.fst id) Positive.One + +(** val max_id_of_fn : Csyntax.function0 -> AST.ident **) +let max_id_of_fn f = + max_id_of_env (List.append f.Csyntax.fn_params f.Csyntax.fn_vars) + +(** val max_id_of_fundef : Csyntax.clight_fundef -> AST.ident **) +let max_id_of_fundef = function +| Csyntax.CL_Internal f0 -> max_id_of_fn f0 +| Csyntax.CL_External (id, x, x0) -> id + +(** val max_id_of_functs : + (AST.ident, Csyntax.clight_fundef) Types.prod List.list -> AST.ident **) +let max_id_of_functs = + List.foldr (fun idf id -> + max_id (max_id idf.Types.fst (max_id_of_fundef idf.Types.snd)) id) + Positive.One + +(** val max_id_of_globvars : + ((AST.ident, AST.region) Types.prod, (AST.init_data List.list, + Csyntax.type0) Types.prod) Types.prod List.list -> AST.ident **) +let max_id_of_globvars = + List.foldr (fun it id -> max_id it.Types.fst.Types.fst id) Positive.One + +(** val max_id_of_program : Csyntax.clight_program -> AST.ident **) +let max_id_of_program p = + max_id (max_id (max_id_of_functs p.AST.prog_funct) p.AST.prog_main) + (max_id_of_globvars p.AST.prog_vars) + +(** val universe_of_max : AST.ident -> Identifiers.universe **) +let universe_of_max mx = + let i = mx in let next = Positive.succ i in next + +(** val universe_for_program : + Csyntax.clight_program -> Identifiers.universe **) +let universe_for_program p = + universe_of_max (max_id_of_program p) + diff --git a/extracted/fresh.mli b/extracted/fresh.mli new file mode 100644 index 0000000..90c0957 --- /dev/null +++ b/extracted/fresh.mli @@ -0,0 +1,98 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +val max_id : AST.ident -> AST.ident -> AST.ident + +val max_id_of_env : + (AST.ident, Csyntax.type0) Types.prod List.list -> AST.ident + +val max_id_of_fn : Csyntax.function0 -> AST.ident + +val max_id_of_fundef : Csyntax.clight_fundef -> AST.ident + +val max_id_of_functs : + (AST.ident, Csyntax.clight_fundef) Types.prod List.list -> AST.ident + +val max_id_of_globvars : + ((AST.ident, AST.region) Types.prod, (AST.init_data List.list, + Csyntax.type0) Types.prod) Types.prod List.list -> AST.ident + +val max_id_of_program : Csyntax.clight_program -> AST.ident + +val universe_of_max : AST.ident -> Identifiers.universe + +val universe_for_program : Csyntax.clight_program -> Identifiers.universe + diff --git a/extracted/frontEndMem.ml b/extracted/frontEndMem.ml new file mode 100644 index 0000000..75fd8f4 --- /dev/null +++ b/extracted/frontEndMem.ml @@ -0,0 +1,163 @@ +open Preamble + +open Hide + +open ByteValues + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open GenMem + +open Coqlib + +open Values + +open FrontEndVal + +(** val loadn : + GenMem.mem -> Pointers.pointer -> Nat.nat -> ByteValues.beval List.list + Types.option **) +let rec loadn m ptr = function +| Nat.O -> Types.Some List.Nil +| Nat.S n' -> + (match GenMem.beloadv m ptr with + | Types.None -> Types.None + | Types.Some v -> + (match loadn m + (Pointers.shift_pointer (Nat.S (Nat.S Nat.O)) ptr + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S Nat.O)) (Nat.S + Nat.O))) n' with + | Types.None -> Types.None + | Types.Some vs -> Types.Some (List.Cons (v, vs)))) + +(** val load : + AST.typ -> GenMem.mem -> Pointers.pointer -> Values.val0 Types.option **) +let load t m ptr = + match loadn m ptr (AST.typesize t) with + | Types.None -> Types.None + | Types.Some vs -> Types.Some (FrontEndVal.be_to_fe_value t vs) + +(** val loadv : + AST.typ -> GenMem.mem -> Values.val0 -> Values.val0 Types.option **) +let rec loadv t m = function +| Values.Vundef -> Types.None +| Values.Vint (x, x0) -> Types.None +| Values.Vnull -> Types.None +| Values.Vptr ptr -> load t m ptr + +(** val storen : + GenMem.mem -> Pointers.pointer -> ByteValues.beval List.list -> + GenMem.mem Types.option **) +let rec storen m ptr = function +| List.Nil -> Types.Some m +| List.Cons (v, tl) -> + (match GenMem.bestorev m ptr v with + | Types.None -> Types.None + | Types.Some m' -> + storen m' + (Pointers.shift_pointer (Nat.S (Nat.S Nat.O)) ptr + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S Nat.O)) (Nat.S Nat.O))) + tl) + +(** val store : + AST.typ -> GenMem.mem -> Pointers.pointer -> Values.val0 -> GenMem.mem + Types.option **) +let store t m ptr v = + storen m ptr (FrontEndVal.fe_to_be_values t v) + +(** val storev : + AST.typ -> GenMem.mem -> Values.val0 -> Values.val0 -> GenMem.mem + Types.option **) +let storev t m addr v = + match addr with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> Types.None + | Values.Vptr ptr -> store t m ptr v + +(** val valid_pointer : GenMem.mem -> Pointers.pointer -> Bool.bool **) +let valid_pointer m ptr = + let off = + BitVectorZ.z_of_unsigned_bitvector Pointers.offset_size + (Pointers.offv ptr.Pointers.poff) + in + Bool.andb + (Bool.andb + (Z.zltb (Pointers.block_id ptr.Pointers.pblock) m.GenMem.nextblock) + (Z.zleb (GenMem.low_bound m ptr.Pointers.pblock) off)) + (Z.zltb off (GenMem.high_bound m ptr.Pointers.pblock)) + diff --git a/extracted/frontEndMem.mli b/extracted/frontEndMem.mli new file mode 100644 index 0000000..7ce925f --- /dev/null +++ b/extracted/frontEndMem.mli @@ -0,0 +1,113 @@ +open Preamble + +open Hide + +open ByteValues + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open GenMem + +open Coqlib + +open Values + +open FrontEndVal + +val loadn : + GenMem.mem -> Pointers.pointer -> Nat.nat -> ByteValues.beval List.list + Types.option + +val load : + AST.typ -> GenMem.mem -> Pointers.pointer -> Values.val0 Types.option + +val loadv : AST.typ -> GenMem.mem -> Values.val0 -> Values.val0 Types.option + +val storen : + GenMem.mem -> Pointers.pointer -> ByteValues.beval List.list -> GenMem.mem + Types.option + +val store : + AST.typ -> GenMem.mem -> Pointers.pointer -> Values.val0 -> GenMem.mem + Types.option + +val storev : + AST.typ -> GenMem.mem -> Values.val0 -> Values.val0 -> GenMem.mem + Types.option + +val valid_pointer : GenMem.mem -> Pointers.pointer -> Bool.bool + diff --git a/extracted/frontEndOps.ml b/extracted/frontEndOps.ml new file mode 100644 index 0000000..c261825 --- /dev/null +++ b/extracted/frontEndOps.ml @@ -0,0 +1,1353 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +type constant = +| Ointconst of AST.intsize * AST.signedness * AST.bvint +| Oaddrsymbol of AST.ident * Nat.nat +| Oaddrstack of Nat.nat + +(** val constant_rect_Type4 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 **) +let rec constant_rect_Type4 h_Ointconst h_Oaddrsymbol h_Oaddrstack x_13118 = function +| Ointconst (sz, sg, x_13120) -> h_Ointconst sz sg x_13120 +| Oaddrsymbol (x_13122, x_13121) -> h_Oaddrsymbol x_13122 x_13121 +| Oaddrstack x_13123 -> h_Oaddrstack x_13123 + +(** val constant_rect_Type5 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 **) +let rec constant_rect_Type5 h_Ointconst h_Oaddrsymbol h_Oaddrstack x_13127 = function +| Ointconst (sz, sg, x_13129) -> h_Ointconst sz sg x_13129 +| Oaddrsymbol (x_13131, x_13130) -> h_Oaddrsymbol x_13131 x_13130 +| Oaddrstack x_13132 -> h_Oaddrstack x_13132 + +(** val constant_rect_Type3 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 **) +let rec constant_rect_Type3 h_Ointconst h_Oaddrsymbol h_Oaddrstack x_13136 = function +| Ointconst (sz, sg, x_13138) -> h_Ointconst sz sg x_13138 +| Oaddrsymbol (x_13140, x_13139) -> h_Oaddrsymbol x_13140 x_13139 +| Oaddrstack x_13141 -> h_Oaddrstack x_13141 + +(** val constant_rect_Type2 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 **) +let rec constant_rect_Type2 h_Ointconst h_Oaddrsymbol h_Oaddrstack x_13145 = function +| Ointconst (sz, sg, x_13147) -> h_Ointconst sz sg x_13147 +| Oaddrsymbol (x_13149, x_13148) -> h_Oaddrsymbol x_13149 x_13148 +| Oaddrstack x_13150 -> h_Oaddrstack x_13150 + +(** val constant_rect_Type1 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 **) +let rec constant_rect_Type1 h_Ointconst h_Oaddrsymbol h_Oaddrstack x_13154 = function +| Ointconst (sz, sg, x_13156) -> h_Ointconst sz sg x_13156 +| Oaddrsymbol (x_13158, x_13157) -> h_Oaddrsymbol x_13158 x_13157 +| Oaddrstack x_13159 -> h_Oaddrstack x_13159 + +(** val constant_rect_Type0 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 **) +let rec constant_rect_Type0 h_Ointconst h_Oaddrsymbol h_Oaddrstack x_13163 = function +| Ointconst (sz, sg, x_13165) -> h_Ointconst sz sg x_13165 +| Oaddrsymbol (x_13167, x_13166) -> h_Oaddrsymbol x_13167 x_13166 +| Oaddrstack x_13168 -> h_Oaddrstack x_13168 + +(** val constant_inv_rect_Type4 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ + -> __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> + __ -> __ -> 'a1) -> 'a1 **) +let constant_inv_rect_Type4 x1 hterm h1 h2 h3 = + let hcut = constant_rect_Type4 h1 h2 h3 x1 hterm in hcut __ __ + +(** val constant_inv_rect_Type3 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ + -> __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> + __ -> __ -> 'a1) -> 'a1 **) +let constant_inv_rect_Type3 x1 hterm h1 h2 h3 = + let hcut = constant_rect_Type3 h1 h2 h3 x1 hterm in hcut __ __ + +(** val constant_inv_rect_Type2 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ + -> __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> + __ -> __ -> 'a1) -> 'a1 **) +let constant_inv_rect_Type2 x1 hterm h1 h2 h3 = + let hcut = constant_rect_Type2 h1 h2 h3 x1 hterm in hcut __ __ + +(** val constant_inv_rect_Type1 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ + -> __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> + __ -> __ -> 'a1) -> 'a1 **) +let constant_inv_rect_Type1 x1 hterm h1 h2 h3 = + let hcut = constant_rect_Type1 h1 h2 h3 x1 hterm in hcut __ __ + +(** val constant_inv_rect_Type0 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ + -> __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> + __ -> __ -> 'a1) -> 'a1 **) +let constant_inv_rect_Type0 x1 hterm h1 h2 h3 = + let hcut = constant_rect_Type0 h1 h2 h3 x1 hterm in hcut __ __ + +(** val constant_discr : AST.typ -> constant -> constant -> __ **) +let constant_discr a1 x y = + Logic.eq_rect_Type2 x + (match x with + | Ointconst (a0, a10, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Oaddrsymbol (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oaddrstack a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val constant_jmdiscr : AST.typ -> constant -> constant -> __ **) +let constant_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (match x with + | Ointconst (a0, a10, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Oaddrsymbol (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oaddrstack a0 -> Obj.magic (fun _ dH -> dH __)) y + +type unary_operation = +| Ocastint of AST.intsize * AST.signedness * AST.intsize * AST.signedness +| Onegint of AST.intsize * AST.signedness +| Onotbool of AST.typ * AST.intsize * AST.signedness +| Onotint of AST.intsize * AST.signedness +| Oid of AST.typ +| Optrofint of AST.intsize * AST.signedness +| Ointofptr of AST.intsize * AST.signedness + +(** val unary_operation_rect_Type4 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> + unary_operation -> 'a1 **) +let rec unary_operation_rect_Type4 h_Ocastint h_Onegint h_Onotbool h_Onotint h_Oid h_Optrofint h_Ointofptr x_13238 x_13237 = function +| Ocastint (sz, sg, sz', sg') -> h_Ocastint sz sg sz' sg' +| Onegint (sz, sg) -> h_Onegint sz sg +| Onotbool (t, sz, sg) -> h_Onotbool t sz sg __ +| Onotint (sz, sg) -> h_Onotint sz sg +| Oid t -> h_Oid t +| Optrofint (sz, sg) -> h_Optrofint sz sg +| Ointofptr (sz, sg) -> h_Ointofptr sz sg + +(** val unary_operation_rect_Type5 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> + unary_operation -> 'a1 **) +let rec unary_operation_rect_Type5 h_Ocastint h_Onegint h_Onotbool h_Onotint h_Oid h_Optrofint h_Ointofptr x_13249 x_13248 = function +| Ocastint (sz, sg, sz', sg') -> h_Ocastint sz sg sz' sg' +| Onegint (sz, sg) -> h_Onegint sz sg +| Onotbool (t, sz, sg) -> h_Onotbool t sz sg __ +| Onotint (sz, sg) -> h_Onotint sz sg +| Oid t -> h_Oid t +| Optrofint (sz, sg) -> h_Optrofint sz sg +| Ointofptr (sz, sg) -> h_Ointofptr sz sg + +(** val unary_operation_rect_Type3 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> + unary_operation -> 'a1 **) +let rec unary_operation_rect_Type3 h_Ocastint h_Onegint h_Onotbool h_Onotint h_Oid h_Optrofint h_Ointofptr x_13260 x_13259 = function +| Ocastint (sz, sg, sz', sg') -> h_Ocastint sz sg sz' sg' +| Onegint (sz, sg) -> h_Onegint sz sg +| Onotbool (t, sz, sg) -> h_Onotbool t sz sg __ +| Onotint (sz, sg) -> h_Onotint sz sg +| Oid t -> h_Oid t +| Optrofint (sz, sg) -> h_Optrofint sz sg +| Ointofptr (sz, sg) -> h_Ointofptr sz sg + +(** val unary_operation_rect_Type2 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> + unary_operation -> 'a1 **) +let rec unary_operation_rect_Type2 h_Ocastint h_Onegint h_Onotbool h_Onotint h_Oid h_Optrofint h_Ointofptr x_13271 x_13270 = function +| Ocastint (sz, sg, sz', sg') -> h_Ocastint sz sg sz' sg' +| Onegint (sz, sg) -> h_Onegint sz sg +| Onotbool (t, sz, sg) -> h_Onotbool t sz sg __ +| Onotint (sz, sg) -> h_Onotint sz sg +| Oid t -> h_Oid t +| Optrofint (sz, sg) -> h_Optrofint sz sg +| Ointofptr (sz, sg) -> h_Ointofptr sz sg + +(** val unary_operation_rect_Type1 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> + unary_operation -> 'a1 **) +let rec unary_operation_rect_Type1 h_Ocastint h_Onegint h_Onotbool h_Onotint h_Oid h_Optrofint h_Ointofptr x_13282 x_13281 = function +| Ocastint (sz, sg, sz', sg') -> h_Ocastint sz sg sz' sg' +| Onegint (sz, sg) -> h_Onegint sz sg +| Onotbool (t, sz, sg) -> h_Onotbool t sz sg __ +| Onotint (sz, sg) -> h_Onotint sz sg +| Oid t -> h_Oid t +| Optrofint (sz, sg) -> h_Optrofint sz sg +| Ointofptr (sz, sg) -> h_Ointofptr sz sg + +(** val unary_operation_rect_Type0 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> + unary_operation -> 'a1 **) +let rec unary_operation_rect_Type0 h_Ocastint h_Onegint h_Onotbool h_Onotint h_Oid h_Optrofint h_Ointofptr x_13293 x_13292 = function +| Ocastint (sz, sg, sz', sg') -> h_Ocastint sz sg sz' sg' +| Onegint (sz, sg) -> h_Onegint sz sg +| Onotbool (t, sz, sg) -> h_Onotbool t sz sg __ +| Onotint (sz, sg) -> h_Onotint sz sg +| Oid t -> h_Oid t +| Optrofint (sz, sg) -> h_Optrofint sz sg +| Ointofptr (sz, sg) -> h_Ointofptr sz sg + +(** val unary_operation_inv_rect_Type4 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness + -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> + __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let unary_operation_inv_rect_Type4 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = unary_operation_rect_Type4 h1 h2 h3 h4 h5 h6 h7 x1 x2 hterm in + hcut __ __ __ + +(** val unary_operation_inv_rect_Type3 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness + -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> + __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let unary_operation_inv_rect_Type3 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = unary_operation_rect_Type3 h1 h2 h3 h4 h5 h6 h7 x1 x2 hterm in + hcut __ __ __ + +(** val unary_operation_inv_rect_Type2 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness + -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> + __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let unary_operation_inv_rect_Type2 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = unary_operation_rect_Type2 h1 h2 h3 h4 h5 h6 h7 x1 x2 hterm in + hcut __ __ __ + +(** val unary_operation_inv_rect_Type1 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness + -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> + __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let unary_operation_inv_rect_Type1 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = unary_operation_rect_Type1 h1 h2 h3 h4 h5 h6 h7 x1 x2 hterm in + hcut __ __ __ + +(** val unary_operation_inv_rect_Type0 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness + -> AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> + __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let unary_operation_inv_rect_Type0 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 = + let hcut = unary_operation_rect_Type0 h1 h2 h3 h4 h5 h6 h7 x1 x2 hterm in + hcut __ __ __ + +(** val unary_operation_discr : + AST.typ -> AST.typ -> unary_operation -> unary_operation -> __ **) +let unary_operation_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Ocastint (a0, a10, a20, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Onegint (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Onotbool (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Onotint (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oid a0 -> Obj.magic (fun _ dH -> dH __) + | Optrofint (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Ointofptr (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val unary_operation_jmdiscr : + AST.typ -> AST.typ -> unary_operation -> unary_operation -> __ **) +let unary_operation_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Ocastint (a0, a10, a20, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Onegint (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Onotbool (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Onotint (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oid a0 -> Obj.magic (fun _ dH -> dH __) + | Optrofint (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Ointofptr (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +type binary_operation = +| Oadd of AST.intsize * AST.signedness +| Osub of AST.intsize * AST.signedness +| Omul of AST.intsize * AST.signedness +| Odiv of AST.intsize +| Odivu of AST.intsize +| Omod of AST.intsize +| Omodu of AST.intsize +| Oand of AST.intsize * AST.signedness +| Oor of AST.intsize * AST.signedness +| Oxor of AST.intsize * AST.signedness +| Oshl of AST.intsize * AST.signedness +| Oshr of AST.intsize * AST.signedness +| Oshru of AST.intsize * AST.signedness +| Ocmp of AST.intsize * AST.signedness * AST.signedness * Integers.comparison +| Ocmpu of AST.intsize * AST.signedness * Integers.comparison +| Oaddpi of AST.intsize +| Oaddip of AST.intsize +| Osubpi of AST.intsize +| Osubpp of AST.intsize +| Ocmpp of AST.signedness * Integers.comparison + +(** val binary_operation_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.signedness -> Integers.comparison -> 'a1) -> + AST.typ -> AST.typ -> AST.typ -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type4 h_Oadd h_Osub h_Omul h_Odiv h_Odivu h_Omod h_Omodu h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oshru h_Ocmp h_Ocmpu h_Oaddpi h_Oaddip h_Osubpi h_Osubpp h_Ocmpp x_13398 x_13397 x_13396 = function +| Oadd (sz, sg) -> h_Oadd sz sg +| Osub (sz, sg) -> h_Osub sz sg +| Omul (sz, sg) -> h_Omul sz sg +| Odiv sz -> h_Odiv sz +| Odivu sz -> h_Odivu sz +| Omod sz -> h_Omod sz +| Omodu sz -> h_Omodu sz +| Oand (sz, sg) -> h_Oand sz sg +| Oor (sz, sg) -> h_Oor sz sg +| Oxor (sz, sg) -> h_Oxor sz sg +| Oshl (sz, sg) -> h_Oshl sz sg +| Oshr (sz, sg) -> h_Oshr sz sg +| Oshru (sz, sg) -> h_Oshru sz sg +| Ocmp (sz, sg, sg', x_13400) -> h_Ocmp sz sg sg' x_13400 +| Ocmpu (sz, sg', x_13401) -> h_Ocmpu sz sg' x_13401 +| Oaddpi sz -> h_Oaddpi sz +| Oaddip sz -> h_Oaddip sz +| Osubpi sz -> h_Osubpi sz +| Osubpp sz -> h_Osubpp sz +| Ocmpp (sg', x_13402) -> h_Ocmpp sg' x_13402 + +(** val binary_operation_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.signedness -> Integers.comparison -> 'a1) -> + AST.typ -> AST.typ -> AST.typ -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type5 h_Oadd h_Osub h_Omul h_Odiv h_Odivu h_Omod h_Omodu h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oshru h_Ocmp h_Ocmpu h_Oaddpi h_Oaddip h_Osubpi h_Osubpp h_Ocmpp x_13425 x_13424 x_13423 = function +| Oadd (sz, sg) -> h_Oadd sz sg +| Osub (sz, sg) -> h_Osub sz sg +| Omul (sz, sg) -> h_Omul sz sg +| Odiv sz -> h_Odiv sz +| Odivu sz -> h_Odivu sz +| Omod sz -> h_Omod sz +| Omodu sz -> h_Omodu sz +| Oand (sz, sg) -> h_Oand sz sg +| Oor (sz, sg) -> h_Oor sz sg +| Oxor (sz, sg) -> h_Oxor sz sg +| Oshl (sz, sg) -> h_Oshl sz sg +| Oshr (sz, sg) -> h_Oshr sz sg +| Oshru (sz, sg) -> h_Oshru sz sg +| Ocmp (sz, sg, sg', x_13427) -> h_Ocmp sz sg sg' x_13427 +| Ocmpu (sz, sg', x_13428) -> h_Ocmpu sz sg' x_13428 +| Oaddpi sz -> h_Oaddpi sz +| Oaddip sz -> h_Oaddip sz +| Osubpi sz -> h_Osubpi sz +| Osubpp sz -> h_Osubpp sz +| Ocmpp (sg', x_13429) -> h_Ocmpp sg' x_13429 + +(** val binary_operation_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.signedness -> Integers.comparison -> 'a1) -> + AST.typ -> AST.typ -> AST.typ -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type3 h_Oadd h_Osub h_Omul h_Odiv h_Odivu h_Omod h_Omodu h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oshru h_Ocmp h_Ocmpu h_Oaddpi h_Oaddip h_Osubpi h_Osubpp h_Ocmpp x_13452 x_13451 x_13450 = function +| Oadd (sz, sg) -> h_Oadd sz sg +| Osub (sz, sg) -> h_Osub sz sg +| Omul (sz, sg) -> h_Omul sz sg +| Odiv sz -> h_Odiv sz +| Odivu sz -> h_Odivu sz +| Omod sz -> h_Omod sz +| Omodu sz -> h_Omodu sz +| Oand (sz, sg) -> h_Oand sz sg +| Oor (sz, sg) -> h_Oor sz sg +| Oxor (sz, sg) -> h_Oxor sz sg +| Oshl (sz, sg) -> h_Oshl sz sg +| Oshr (sz, sg) -> h_Oshr sz sg +| Oshru (sz, sg) -> h_Oshru sz sg +| Ocmp (sz, sg, sg', x_13454) -> h_Ocmp sz sg sg' x_13454 +| Ocmpu (sz, sg', x_13455) -> h_Ocmpu sz sg' x_13455 +| Oaddpi sz -> h_Oaddpi sz +| Oaddip sz -> h_Oaddip sz +| Osubpi sz -> h_Osubpi sz +| Osubpp sz -> h_Osubpp sz +| Ocmpp (sg', x_13456) -> h_Ocmpp sg' x_13456 + +(** val binary_operation_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.signedness -> Integers.comparison -> 'a1) -> + AST.typ -> AST.typ -> AST.typ -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type2 h_Oadd h_Osub h_Omul h_Odiv h_Odivu h_Omod h_Omodu h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oshru h_Ocmp h_Ocmpu h_Oaddpi h_Oaddip h_Osubpi h_Osubpp h_Ocmpp x_13479 x_13478 x_13477 = function +| Oadd (sz, sg) -> h_Oadd sz sg +| Osub (sz, sg) -> h_Osub sz sg +| Omul (sz, sg) -> h_Omul sz sg +| Odiv sz -> h_Odiv sz +| Odivu sz -> h_Odivu sz +| Omod sz -> h_Omod sz +| Omodu sz -> h_Omodu sz +| Oand (sz, sg) -> h_Oand sz sg +| Oor (sz, sg) -> h_Oor sz sg +| Oxor (sz, sg) -> h_Oxor sz sg +| Oshl (sz, sg) -> h_Oshl sz sg +| Oshr (sz, sg) -> h_Oshr sz sg +| Oshru (sz, sg) -> h_Oshru sz sg +| Ocmp (sz, sg, sg', x_13481) -> h_Ocmp sz sg sg' x_13481 +| Ocmpu (sz, sg', x_13482) -> h_Ocmpu sz sg' x_13482 +| Oaddpi sz -> h_Oaddpi sz +| Oaddip sz -> h_Oaddip sz +| Osubpi sz -> h_Osubpi sz +| Osubpp sz -> h_Osubpp sz +| Ocmpp (sg', x_13483) -> h_Ocmpp sg' x_13483 + +(** val binary_operation_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.signedness -> Integers.comparison -> 'a1) -> + AST.typ -> AST.typ -> AST.typ -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type1 h_Oadd h_Osub h_Omul h_Odiv h_Odivu h_Omod h_Omodu h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oshru h_Ocmp h_Ocmpu h_Oaddpi h_Oaddip h_Osubpi h_Osubpp h_Ocmpp x_13506 x_13505 x_13504 = function +| Oadd (sz, sg) -> h_Oadd sz sg +| Osub (sz, sg) -> h_Osub sz sg +| Omul (sz, sg) -> h_Omul sz sg +| Odiv sz -> h_Odiv sz +| Odivu sz -> h_Odivu sz +| Omod sz -> h_Omod sz +| Omodu sz -> h_Omodu sz +| Oand (sz, sg) -> h_Oand sz sg +| Oor (sz, sg) -> h_Oor sz sg +| Oxor (sz, sg) -> h_Oxor sz sg +| Oshl (sz, sg) -> h_Oshl sz sg +| Oshr (sz, sg) -> h_Oshr sz sg +| Oshru (sz, sg) -> h_Oshru sz sg +| Ocmp (sz, sg, sg', x_13508) -> h_Ocmp sz sg sg' x_13508 +| Ocmpu (sz, sg', x_13509) -> h_Ocmpu sz sg' x_13509 +| Oaddpi sz -> h_Oaddpi sz +| Oaddip sz -> h_Oaddip sz +| Osubpi sz -> h_Osubpi sz +| Osubpp sz -> h_Osubpp sz +| Ocmpp (sg', x_13510) -> h_Ocmpp sg' x_13510 + +(** val binary_operation_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) + -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness + -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> AST.signedness -> Integers.comparison -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.signedness -> Integers.comparison -> 'a1) -> + AST.typ -> AST.typ -> AST.typ -> binary_operation -> 'a1 **) +let rec binary_operation_rect_Type0 h_Oadd h_Osub h_Omul h_Odiv h_Odivu h_Omod h_Omodu h_Oand h_Oor h_Oxor h_Oshl h_Oshr h_Oshru h_Ocmp h_Ocmpu h_Oaddpi h_Oaddip h_Osubpi h_Osubpp h_Ocmpp x_13533 x_13532 x_13531 = function +| Oadd (sz, sg) -> h_Oadd sz sg +| Osub (sz, sg) -> h_Osub sz sg +| Omul (sz, sg) -> h_Omul sz sg +| Odiv sz -> h_Odiv sz +| Odivu sz -> h_Odivu sz +| Omod sz -> h_Omod sz +| Omodu sz -> h_Omodu sz +| Oand (sz, sg) -> h_Oand sz sg +| Oor (sz, sg) -> h_Oor sz sg +| Oxor (sz, sg) -> h_Oxor sz sg +| Oshl (sz, sg) -> h_Oshl sz sg +| Oshr (sz, sg) -> h_Oshr sz sg +| Oshru (sz, sg) -> h_Oshru sz sg +| Ocmp (sz, sg, sg', x_13535) -> h_Ocmp sz sg sg' x_13535 +| Ocmpu (sz, sg', x_13536) -> h_Ocmpu sz sg' x_13536 +| Oaddpi sz -> h_Oaddpi sz +| Oaddip sz -> h_Oaddip sz +| Osubpi sz -> h_Osubpi sz +| Osubpp sz -> h_Osubpp sz +| Ocmpp (sg', x_13537) -> h_Ocmpp sg' x_13537 + +(** val binary_operation_inv_rect_Type4 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ + -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison + -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type4 x1 x2 x3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 = + let hcut = + binary_operation_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 h20 x1 x2 x3 hterm + in + hcut __ __ __ __ + +(** val binary_operation_inv_rect_Type3 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ + -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison + -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type3 x1 x2 x3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 = + let hcut = + binary_operation_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 h20 x1 x2 x3 hterm + in + hcut __ __ __ __ + +(** val binary_operation_inv_rect_Type2 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ + -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison + -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type2 x1 x2 x3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 = + let hcut = + binary_operation_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 h20 x1 x2 x3 hterm + in + hcut __ __ __ __ + +(** val binary_operation_inv_rect_Type1 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ + -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison + -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type1 x1 x2 x3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 = + let hcut = + binary_operation_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 h20 x1 x2 x3 hterm + in + hcut __ __ __ __ + +(** val binary_operation_inv_rect_Type0 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ + -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison + -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> + __ -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let binary_operation_inv_rect_Type0 x1 x2 x3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 = + let hcut = + binary_operation_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + h14 h15 h16 h17 h18 h19 h20 x1 x2 x3 hterm + in + hcut __ __ __ __ + +(** val binary_operation_discr : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> binary_operation -> + __ **) +let binary_operation_discr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (match x with + | Oadd (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Osub (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Omul (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Odiv a0 -> Obj.magic (fun _ dH -> dH __) + | Odivu a0 -> Obj.magic (fun _ dH -> dH __) + | Omod a0 -> Obj.magic (fun _ dH -> dH __) + | Omodu a0 -> Obj.magic (fun _ dH -> dH __) + | Oand (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oor (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oxor (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oshl (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oshr (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oshru (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Ocmp (a0, a10, a20, a30) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Ocmpu (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Oaddpi a0 -> Obj.magic (fun _ dH -> dH __) + | Oaddip a0 -> Obj.magic (fun _ dH -> dH __) + | Osubpi a0 -> Obj.magic (fun _ dH -> dH __) + | Osubpp a0 -> Obj.magic (fun _ dH -> dH __) + | Ocmpp (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val binary_operation_jmdiscr : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> binary_operation -> + __ **) +let binary_operation_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (match x with + | Oadd (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Osub (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Omul (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Odiv a0 -> Obj.magic (fun _ dH -> dH __) + | Odivu a0 -> Obj.magic (fun _ dH -> dH __) + | Omod a0 -> Obj.magic (fun _ dH -> dH __) + | Omodu a0 -> Obj.magic (fun _ dH -> dH __) + | Oand (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oor (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oxor (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oshl (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oshr (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Oshru (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Ocmp (a0, a10, a20, a30) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Ocmpu (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Oaddpi a0 -> Obj.magic (fun _ dH -> dH __) + | Oaddip a0 -> Obj.magic (fun _ dH -> dH __) + | Osubpi a0 -> Obj.magic (fun _ dH -> dH __) + | Osubpp a0 -> Obj.magic (fun _ dH -> dH __) + | Ocmpp (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val eval_constant : + AST.typ -> (AST.ident -> Pointers.block Types.option) -> Pointers.block + -> constant -> Values.val0 Types.option **) +let eval_constant t find_symbol sp = function +| Ointconst (sz, sg, n) -> Types.Some (Values.Vint (sz, n)) +| Oaddrsymbol (s, ofs) -> + (match find_symbol s with + | Types.None -> Types.None + | Types.Some b -> + Types.Some (Values.Vptr { Pointers.pblock = b; Pointers.poff = + (Pointers.shift_offset (AST.bitsize_of_intsize AST.I16) + Pointers.zero_offset (AST.repr AST.I16 ofs)) })) +| Oaddrstack ofs -> + Types.Some (Values.Vptr { Pointers.pblock = sp; Pointers.poff = + (Pointers.shift_offset (AST.bitsize_of_intsize AST.I16) + Pointers.zero_offset (AST.repr AST.I16 ofs)) }) + +(** val eval_unop : + AST.typ -> AST.typ -> unary_operation -> Values.val0 -> Values.val0 + Types.option **) +let eval_unop t t' op arg = + match op with + | Ocastint (sz, sg, sz', sg') -> + (match sg with + | AST.Signed -> Types.Some (Values.sign_ext sz' arg) + | AST.Unsigned -> Types.Some (Values.zero_ext sz' arg)) + | Onegint (sz, sg) -> + (match arg with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + Types.Some (Values.Vint (sz1, + (Arithmetic.two_complement_negation (AST.bitsize_of_intsize sz1) n1))) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Onotbool (t0, sz, sg) -> + (match arg with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + Types.Some (Values.Vint (sz, + (match BitVector.eq_bv (AST.bitsize_of_intsize sz1) n1 + (BitVector.zero (AST.bitsize_of_intsize sz1)) with + | Bool.True -> AST.repr sz (Nat.S Nat.O) + | Bool.False -> BitVector.zero (AST.bitsize_of_intsize sz)))) + | Values.Vnull -> + Types.Some (Values.Vint (sz, (AST.repr sz (Nat.S Nat.O)))) + | Values.Vptr x0 -> + Types.Some (Values.Vint (sz, + (BitVector.zero (AST.bitsize_of_intsize sz))))) + | Onotint (sz, sg) -> + (match arg with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + Types.Some (Values.Vint (sz1, + (BitVector.exclusive_disjunction_bv (AST.bitsize_of_intsize sz1) n1 + (Values.mone sz1)))) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Oid t0 -> Types.Some arg + | Optrofint (sz, sg) -> + (match arg with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match BitVector.eq_bv (AST.bitsize_of_intsize sz1) n1 + (BitVector.zero (AST.bitsize_of_intsize sz1)) with + | Bool.True -> Types.Some Values.Vnull + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Ointofptr (sz, sg) -> + (match arg with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> + Types.Some (Values.Vint (sz, + (BitVector.zero (AST.bitsize_of_intsize sz)))) + | Values.Vptr x -> Types.None) + +(** val eval_compare_mismatch : + Integers.comparison -> Values.val0 Types.option **) +let eval_compare_mismatch = function +| Integers.Ceq -> Types.Some Values.vfalse +| Integers.Cne -> Types.Some Values.vtrue +| Integers.Clt -> Types.None +| Integers.Cle -> Types.None +| Integers.Cgt -> Types.None +| Integers.Cge -> Types.None + +(** val ev_add : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_add v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, (Arithmetic.addition_n (AST.bitsize_of_intsize sz2) n10 n2)))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_sub : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_sub v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (Arithmetic.subtraction (AST.bitsize_of_intsize sz2) n10 n2)))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_addpi : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_addpi v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match BitVector.eq_bv (AST.bitsize_of_intsize sz2) n2 + (BitVector.zero (AST.bitsize_of_intsize sz2)) with + | Bool.True -> Types.Some Values.Vnull + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + Types.Some (Values.Vptr + (Pointers.shift_pointer (AST.bitsize_of_intsize sz2) ptr1 n2)) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + +(** val ev_subpi : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_subpi v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match BitVector.eq_bv (AST.bitsize_of_intsize sz2) n2 + (BitVector.zero (AST.bitsize_of_intsize sz2)) with + | Bool.True -> Types.Some Values.Vnull + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + Types.Some (Values.Vptr + (Pointers.neg_shift_pointer (AST.bitsize_of_intsize sz2) ptr1 n2)) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + +(** val ev_subpp : + AST.intsize -> Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_subpp sz v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> + Types.Some (Values.Vint (sz, + (BitVector.zero (AST.bitsize_of_intsize sz)))) + | Values.Vptr x -> Types.None) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> Types.None + | Values.Vptr ptr2 -> + (match Pointers.eq_block ptr1.Pointers.pblock ptr2.Pointers.pblock with + | Bool.True -> + Types.Some (Values.Vint (sz, + (Pointers.sub_offset (AST.bitsize_of_intsize sz) + ptr1.Pointers.poff ptr2.Pointers.poff))) + | Bool.False -> Types.None)) + +(** val ev_mul : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_mul v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (Arithmetic.short_multiplication (AST.bitsize_of_intsize sz2) n10 + n2)))) Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_divs : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_divs v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x -> Values.Vint (sz2, x)) + (Arithmetic.division_s (AST.bitsize_of_intsize sz2) n10 n2)) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_mods : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_mods v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x -> Values.Vint (sz2, x)) + (Arithmetic.modulus_s (AST.bitsize_of_intsize sz2) n10 n2)) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_divu : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_divu v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x -> Values.Vint (sz2, x)) + (Arithmetic.division_u + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz2) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) n10 n2)) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_modu : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_modu v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + Types.option_map (fun x -> Values.Vint (sz2, x)) + (Arithmetic.modulus_u + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz2) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) n10 n2)) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_and : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_and v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (BitVector.conjunction_bv (AST.bitsize_of_intsize sz2) n10 n2)))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_or : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_or v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (BitVector.inclusive_disjunction_bv (AST.bitsize_of_intsize sz2) n10 + n2)))) Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_xor : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_xor v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some (Values.Vint + (sz2, + (BitVector.exclusive_disjunction_bv (AST.bitsize_of_intsize sz2) n10 + n2)))) Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_shl : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_shl v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match Arithmetic.lt_u (AST.bitsize_of_intsize sz2) n2 + (Arithmetic.bitvector_of_nat (AST.bitsize_of_intsize sz2) + (AST.bitsize_of_intsize sz1)) with + | Bool.True -> + Types.Some (Values.Vint (sz1, + (Vector.shift_left (AST.bitsize_of_intsize sz1) + (Arithmetic.nat_of_bitvector (AST.bitsize_of_intsize sz2) n2) + n1 Bool.False))) + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_shr : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_shr v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match Arithmetic.lt_u (AST.bitsize_of_intsize sz2) n2 + (Arithmetic.bitvector_of_nat (AST.bitsize_of_intsize sz2) + (AST.bitsize_of_intsize sz1)) with + | Bool.True -> + Types.Some (Values.Vint (sz1, + (Vector.shift_right + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz1) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) + (Arithmetic.nat_of_bitvector (AST.bitsize_of_intsize sz2) n2) + n1 + (Vector.head' + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz1) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) n1)))) + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_shru : Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let ev_shru v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + (match Arithmetic.lt_u (AST.bitsize_of_intsize sz2) n2 + (Arithmetic.bitvector_of_nat (AST.bitsize_of_intsize sz2) + (AST.bitsize_of_intsize sz1)) with + | Bool.True -> + Types.Some (Values.Vint (sz1, + (Vector.shift_right + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz1) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) + (Arithmetic.nat_of_bitvector (AST.bitsize_of_intsize sz2) n2) + n1 Bool.False))) + | Bool.False -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val fEtrue : Values.val0 **) +let fEtrue = + Values.Vint (AST.I8, (AST.repr AST.I8 (Nat.S Nat.O))) + +(** val fEfalse : Values.val0 **) +let fEfalse = + Values.Vint (AST.I8, (AST.repr AST.I8 Nat.O)) + +(** val fE_of_bool : Bool.bool -> Values.val0 **) +let fE_of_bool = function +| Bool.True -> fEtrue +| Bool.False -> fEfalse + +(** val ev_cmp_match : Integers.comparison -> Values.val0 Types.option **) +let ev_cmp_match = function +| Integers.Ceq -> Types.Some fEtrue +| Integers.Cne -> Types.Some fEfalse +| Integers.Clt -> Types.None +| Integers.Cle -> Types.None +| Integers.Cgt -> Types.None +| Integers.Cge -> Types.None + +(** val ev_cmp_mismatch : Integers.comparison -> Values.val0 Types.option **) +let ev_cmp_mismatch = function +| Integers.Ceq -> Types.Some fEfalse +| Integers.Cne -> Types.Some fEtrue +| Integers.Clt -> Types.None +| Integers.Cle -> Types.None +| Integers.Cgt -> Types.None +| Integers.Cge -> Types.None + +(** val ev_cmp : + Integers.comparison -> Values.val0 -> Values.val0 -> Values.val0 + Types.option **) +let ev_cmp c v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some + (fE_of_bool (Values.cmp_int (AST.bitsize_of_intsize sz2) c n10 n2))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val ev_cmpp : + GenMem.mem -> Integers.comparison -> Values.val0 -> Values.val0 -> + Values.val0 Types.option **) +let ev_cmpp m c v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> ev_cmp_match c + | Values.Vptr x -> ev_cmp_mismatch c) + | Values.Vptr ptr1 -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (x, x0) -> Types.None + | Values.Vnull -> ev_cmp_mismatch c + | Values.Vptr ptr2 -> + (match Bool.andb (FrontEndMem.valid_pointer m ptr1) + (FrontEndMem.valid_pointer m ptr2) with + | Bool.True -> + (match Pointers.eq_block ptr1.Pointers.pblock ptr2.Pointers.pblock with + | Bool.True -> + Types.Some + (fE_of_bool + (Values.cmp_offset c ptr1.Pointers.poff ptr2.Pointers.poff)) + | Bool.False -> ev_cmp_mismatch c) + | Bool.False -> Types.None)) + +(** val ev_cmpu : + Integers.comparison -> Values.val0 -> Values.val0 -> Values.val0 + Types.option **) +let ev_cmpu c v1 v2 = + match v1 with + | Values.Vundef -> Types.None + | Values.Vint (sz1, n1) -> + (match v2 with + | Values.Vundef -> Types.None + | Values.Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Types.Some + (fE_of_bool (Values.cmpu_int (AST.bitsize_of_intsize sz2) c n10 n2))) + Types.None + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None + +(** val eval_binop : + GenMem.mem -> AST.typ -> AST.typ -> AST.typ -> binary_operation -> + Values.val0 -> Values.val0 -> Values.val0 Types.option **) +let eval_binop m t1 t2 t' = function +| Oadd (x, x0) -> ev_add +| Osub (x, x0) -> ev_sub +| Omul (x, x0) -> ev_mul +| Odiv x -> ev_divs +| Odivu x -> ev_divu +| Omod x -> ev_mods +| Omodu x -> ev_modu +| Oand (x, x0) -> ev_and +| Oor (x, x0) -> ev_or +| Oxor (x, x0) -> ev_xor +| Oshl (x, x0) -> ev_shl +| Oshr (x, x0) -> ev_shr +| Oshru (x, x0) -> ev_shru +| Ocmp (x, x0, x1, c) -> ev_cmp c +| Ocmpu (x, x0, c) -> ev_cmpu c +| Oaddpi x -> ev_addpi +| Oaddip x -> (fun x0 y -> ev_addpi y x0) +| Osubpi x -> ev_subpi +| Osubpp sz -> ev_subpp sz +| Ocmpp (x, c) -> ev_cmpp m c + diff --git a/extracted/frontEndOps.mli b/extracted/frontEndOps.mli new file mode 100644 index 0000000..ffddb94 --- /dev/null +++ b/extracted/frontEndOps.mli @@ -0,0 +1,538 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +type constant = +| Ointconst of AST.intsize * AST.signedness * AST.bvint +| Oaddrsymbol of AST.ident * Nat.nat +| Oaddrstack of Nat.nat + +val constant_rect_Type4 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 + +val constant_rect_Type5 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 + +val constant_rect_Type3 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 + +val constant_rect_Type2 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 + +val constant_rect_Type1 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 + +val constant_rect_Type0 : + (AST.intsize -> AST.signedness -> AST.bvint -> 'a1) -> (AST.ident -> + Nat.nat -> 'a1) -> (Nat.nat -> 'a1) -> AST.typ -> constant -> 'a1 + +val constant_inv_rect_Type4 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ -> + __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> __ + -> __ -> 'a1) -> 'a1 + +val constant_inv_rect_Type3 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ -> + __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> __ + -> __ -> 'a1) -> 'a1 + +val constant_inv_rect_Type2 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ -> + __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> __ + -> __ -> 'a1) -> 'a1 + +val constant_inv_rect_Type1 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ -> + __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> __ + -> __ -> 'a1) -> 'a1 + +val constant_inv_rect_Type0 : + AST.typ -> constant -> (AST.intsize -> AST.signedness -> AST.bvint -> __ -> + __ -> 'a1) -> (AST.ident -> Nat.nat -> __ -> __ -> 'a1) -> (Nat.nat -> __ + -> __ -> 'a1) -> 'a1 + +val constant_discr : AST.typ -> constant -> constant -> __ + +val constant_jmdiscr : AST.typ -> constant -> constant -> __ + +type unary_operation = +| Ocastint of AST.intsize * AST.signedness * AST.intsize * AST.signedness +| Onegint of AST.intsize * AST.signedness +| Onotbool of AST.typ * AST.intsize * AST.signedness +| Onotint of AST.intsize * AST.signedness +| Oid of AST.typ +| Optrofint of AST.intsize * AST.signedness +| Ointofptr of AST.intsize * AST.signedness + +val unary_operation_rect_Type4 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize + -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> unary_operation -> 'a1 + +val unary_operation_rect_Type5 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize + -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> unary_operation -> 'a1 + +val unary_operation_rect_Type3 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize + -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> unary_operation -> 'a1 + +val unary_operation_rect_Type2 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize + -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> unary_operation -> 'a1 + +val unary_operation_rect_Type1 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize + -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> unary_operation -> 'a1 + +val unary_operation_rect_Type0 : + (AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.typ -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize + -> AST.signedness -> 'a1) -> AST.typ -> AST.typ -> unary_operation -> 'a1 + +val unary_operation_inv_rect_Type4 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> __ -> __ -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type3 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> __ -> __ -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type2 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> __ -> __ -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type1 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> __ -> __ -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> 'a1 + +val unary_operation_inv_rect_Type0 : + AST.typ -> AST.typ -> unary_operation -> (AST.intsize -> AST.signedness -> + AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> 'a1) -> (AST.typ -> __ -> __ -> __ -> + 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> 'a1) -> 'a1 + +val unary_operation_discr : + AST.typ -> AST.typ -> unary_operation -> unary_operation -> __ + +val unary_operation_jmdiscr : + AST.typ -> AST.typ -> unary_operation -> unary_operation -> __ + +type binary_operation = +| Oadd of AST.intsize * AST.signedness +| Osub of AST.intsize * AST.signedness +| Omul of AST.intsize * AST.signedness +| Odiv of AST.intsize +| Odivu of AST.intsize +| Omod of AST.intsize +| Omodu of AST.intsize +| Oand of AST.intsize * AST.signedness +| Oor of AST.intsize * AST.signedness +| Oxor of AST.intsize * AST.signedness +| Oshl of AST.intsize * AST.signedness +| Oshr of AST.intsize * AST.signedness +| Oshru of AST.intsize * AST.signedness +| Ocmp of AST.intsize * AST.signedness * AST.signedness * Integers.comparison +| Ocmpu of AST.intsize * AST.signedness * Integers.comparison +| Oaddpi of AST.intsize +| Oaddip of AST.intsize +| Osubpi of AST.intsize +| Osubpp of AST.intsize +| Ocmpp of AST.signedness * Integers.comparison + +val binary_operation_rect_Type4 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.signedness -> Integers.comparison -> 'a1) -> AST.typ -> AST.typ -> + AST.typ -> binary_operation -> 'a1 + +val binary_operation_rect_Type5 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.signedness -> Integers.comparison -> 'a1) -> AST.typ -> AST.typ -> + AST.typ -> binary_operation -> 'a1 + +val binary_operation_rect_Type3 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.signedness -> Integers.comparison -> 'a1) -> AST.typ -> AST.typ -> + AST.typ -> binary_operation -> 'a1 + +val binary_operation_rect_Type2 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.signedness -> Integers.comparison -> 'a1) -> AST.typ -> AST.typ -> + AST.typ -> binary_operation -> 'a1 + +val binary_operation_rect_Type1 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.signedness -> Integers.comparison -> 'a1) -> AST.typ -> AST.typ -> + AST.typ -> binary_operation -> 'a1 + +val binary_operation_rect_Type0 : + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> + AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> 'a1) -> + (AST.intsize -> AST.signedness -> 'a1) -> (AST.intsize -> AST.signedness -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> + AST.signedness -> Integers.comparison -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> (AST.intsize -> 'a1) -> + (AST.signedness -> Integers.comparison -> 'a1) -> AST.typ -> AST.typ -> + AST.typ -> binary_operation -> 'a1 + +val binary_operation_inv_rect_Type4 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> + __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison -> + __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type3 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> + __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison -> + __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type2 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> + __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison -> + __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type1 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> + __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison -> + __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val binary_operation_inv_rect_Type0 : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> + AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> + __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ + -> 'a1) -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> __ -> __ -> __ -> __ -> 'a1) -> + (AST.intsize -> AST.signedness -> AST.signedness -> Integers.comparison -> + __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> AST.signedness -> + Integers.comparison -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ + -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) + -> (AST.intsize -> __ -> __ -> __ -> __ -> 'a1) -> (AST.intsize -> __ -> __ + -> __ -> __ -> 'a1) -> (AST.signedness -> Integers.comparison -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val binary_operation_discr : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> binary_operation -> __ + +val binary_operation_jmdiscr : + AST.typ -> AST.typ -> AST.typ -> binary_operation -> binary_operation -> __ + +val eval_constant : + AST.typ -> (AST.ident -> Pointers.block Types.option) -> Pointers.block -> + constant -> Values.val0 Types.option + +val eval_unop : + AST.typ -> AST.typ -> unary_operation -> Values.val0 -> Values.val0 + Types.option + +val eval_compare_mismatch : Integers.comparison -> Values.val0 Types.option + +val ev_add : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_sub : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_addpi : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_subpi : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_subpp : + AST.intsize -> Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_mul : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_divs : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_mods : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_divu : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_modu : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_and : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_or : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_xor : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_shl : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_shr : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val ev_shru : Values.val0 -> Values.val0 -> Values.val0 Types.option + +val fEtrue : Values.val0 + +val fEfalse : Values.val0 + +val fE_of_bool : Bool.bool -> Values.val0 + +val ev_cmp_match : Integers.comparison -> Values.val0 Types.option + +val ev_cmp_mismatch : Integers.comparison -> Values.val0 Types.option + +val ev_cmp : + Integers.comparison -> Values.val0 -> Values.val0 -> Values.val0 + Types.option + +val ev_cmpp : + GenMem.mem -> Integers.comparison -> Values.val0 -> Values.val0 -> + Values.val0 Types.option + +val ev_cmpu : + Integers.comparison -> Values.val0 -> Values.val0 -> Values.val0 + Types.option + +val eval_binop : + GenMem.mem -> AST.typ -> AST.typ -> AST.typ -> binary_operation -> + Values.val0 -> Values.val0 -> Values.val0 Types.option + diff --git a/extracted/frontEndVal.ml b/extracted/frontEndVal.ml new file mode 100644 index 0000000..5e9be98 --- /dev/null +++ b/extracted/frontEndVal.ml @@ -0,0 +1,191 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Hide + +open ByteValues + +(** val make_parts : ByteValues.part List.list **) +let make_parts = + List.map ByteValues.part_from_sig (Lists.range_strong AST.size_pointer) + +(** val make_be_null : ByteValues.beval List.list **) +let make_be_null = + List.map (fun p -> ByteValues.BVnull p) make_parts + +(** val bytes_of_bitvector : + Nat.nat -> BitVector.bitVector -> BitVector.byte List.list **) +let rec bytes_of_bitvector n v = + (match n with + | Nat.O -> (fun x -> List.Nil) + | Nat.S m -> + (fun v0 -> + let { Types.fst = h; Types.snd = t } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Nat.times m (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) v0 + in + List.Cons (h, (bytes_of_bitvector m t)))) v + +(** val fe_to_be_values : + AST.typ -> Values.val0 -> ByteValues.beval List.list **) +let fe_to_be_values t = function +| Values.Vundef -> List.make_list ByteValues.BVundef (AST.typesize t) +| Values.Vint (sz, i) -> + List.map (fun b -> ByteValues.BVByte b) + (bytes_of_bitvector (AST.size_intsize sz) i) +| Values.Vnull -> make_be_null +| Values.Vptr ptr -> ByteValues.bevals_of_pointer ptr + +(** val check_be_null : + Nat.nat -> ByteValues.beval List.list -> Bool.bool **) +let rec check_be_null n = function +| List.Nil -> Nat.eqb AST.size_pointer n +| List.Cons (hd, tl) -> + (match hd with + | ByteValues.BVundef -> Bool.False + | ByteValues.BVnonzero -> Bool.False + | ByteValues.BVXor (x, x0, x1) -> Bool.False + | ByteValues.BVByte x -> Bool.False + | ByteValues.BVnull pt -> + Bool.andb (Nat.eqb (ByteValues.part_no pt) n) + (check_be_null (Nat.S n) tl) + | ByteValues.BVptr (x, x0) -> Bool.False + | ByteValues.BVpc (x, x0) -> Bool.False) + +(** val build_integer : + Nat.nat -> ByteValues.beval List.list -> BitVector.bitVector Types.option **) +let rec build_integer n l = + match n with + | Nat.O -> + (match l with + | List.Nil -> Types.Some Vector.VEmpty + | List.Cons (x, x0) -> Types.None) + | Nat.S m -> + (match l with + | List.Nil -> Types.None + | List.Cons (h, t) -> + (match h with + | ByteValues.BVundef -> Types.None + | ByteValues.BVnonzero -> Types.None + | ByteValues.BVXor (x, x0, x1) -> Types.None + | ByteValues.BVByte b -> + Types.option_map (fun tl -> + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Nat.times m (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) b tl) (build_integer m t) + | ByteValues.BVnull x -> Types.None + | ByteValues.BVptr (x, x0) -> Types.None + | ByteValues.BVpc (x, x0) -> Types.None)) + +(** val build_integer_val : + AST.typ -> ByteValues.beval List.list -> Values.val0 **) +let build_integer_val t l = + match t with + | AST.ASTint (sz, sg) -> + Types.option_map_def (fun x -> Values.Vint (sz, x)) Values.Vundef + (build_integer (AST.size_intsize sz) l) + | AST.ASTptr -> Values.Vundef + +(** val be_to_fe_value : + AST.typ -> ByteValues.beval List.list -> Values.val0 **) +let be_to_fe_value ty l = match l with +| List.Nil -> Values.Vundef +| List.Cons (h, t) -> + (match h with + | ByteValues.BVundef -> Values.Vundef + | ByteValues.BVnonzero -> Values.Vundef + | ByteValues.BVXor (x, x0, x1) -> Values.Vundef + | ByteValues.BVByte b -> build_integer_val ty l + | ByteValues.BVnull pt -> + (match Bool.andb (Nat.eqb (ByteValues.part_no pt) Nat.O) + (check_be_null (Nat.S Nat.O) t) with + | Bool.True -> Values.Vnull + | Bool.False -> Values.Vundef) + | ByteValues.BVptr (x, x0) -> + (match ByteValues.pointer_of_bevals l with + | Errors.OK ptr -> Values.Vptr ptr + | Errors.Error x1 -> Values.Vundef) + | ByteValues.BVpc (x, x0) -> Values.Vundef) + diff --git a/extracted/frontEndVal.mli b/extracted/frontEndVal.mli new file mode 100644 index 0000000..3ee06e7 --- /dev/null +++ b/extracted/frontEndVal.mli @@ -0,0 +1,104 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Hide + +open ByteValues + +val make_parts : ByteValues.part List.list + +val make_be_null : ByteValues.beval List.list + +val bytes_of_bitvector : + Nat.nat -> BitVector.bitVector -> BitVector.byte List.list + +val fe_to_be_values : AST.typ -> Values.val0 -> ByteValues.beval List.list + +val check_be_null : Nat.nat -> ByteValues.beval List.list -> Bool.bool + +val build_integer : + Nat.nat -> ByteValues.beval List.list -> BitVector.bitVector Types.option + +val build_integer_val : AST.typ -> ByteValues.beval List.list -> Values.val0 + +val be_to_fe_value : AST.typ -> ByteValues.beval List.list -> Values.val0 + diff --git a/extracted/frontend_misc.ml b/extracted/frontend_misc.ml new file mode 100644 index 0000000..641540d --- /dev/null +++ b/extracted/frontend_misc.ml @@ -0,0 +1,279 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open Star + +open IOMonad + +open IO + +open Sets + +open Listb + +(** val typ_eq_dec : AST.typ -> AST.typ -> (__, __) Types.sum **) +let typ_eq_dec t1 t2 = + match t1 with + | AST.ASTint (x, x0) -> + (match t2 with + | AST.ASTint (sz, sg) -> + (fun sz' sg' -> + match sz with + | AST.I8 -> + (match sz' with + | AST.I8 -> + AST.typ_eq (AST.ASTint (AST.I8, sg')) (AST.ASTint (AST.I8, sg)) + | AST.I16 -> + AST.typ_eq (AST.ASTint (AST.I16, sg')) (AST.ASTint (AST.I8, + sg)) + | AST.I32 -> + AST.typ_eq (AST.ASTint (AST.I32, sg')) (AST.ASTint (AST.I8, + sg))) + | AST.I16 -> + (match sz' with + | AST.I8 -> + AST.typ_eq (AST.ASTint (AST.I8, sg')) (AST.ASTint (AST.I16, + sg)) + | AST.I16 -> + AST.typ_eq (AST.ASTint (AST.I16, sg')) (AST.ASTint (AST.I16, + sg)) + | AST.I32 -> + AST.typ_eq (AST.ASTint (AST.I32, sg')) (AST.ASTint (AST.I16, + sg))) + | AST.I32 -> + (match sz' with + | AST.I8 -> + AST.typ_eq (AST.ASTint (AST.I8, sg')) (AST.ASTint (AST.I32, + sg)) + | AST.I16 -> + AST.typ_eq (AST.ASTint (AST.I16, sg')) (AST.ASTint (AST.I32, + sg)) + | AST.I32 -> + AST.typ_eq (AST.ASTint (AST.I32, sg')) (AST.ASTint (AST.I32, + sg)))) + | AST.ASTptr -> (fun sz sg -> Types.Inr __)) x x0 + | AST.ASTptr -> + (match t2 with + | AST.ASTint (sz, sg) -> Types.Inr __ + | AST.ASTptr -> Types.Inl __) + +(** val block_DeqSet : Deqsets.deqSet **) +let block_DeqSet = + Obj.magic Pointers.eq_block + +(** val mem_assoc_env : + AST.ident -> (AST.ident, Csyntax.type0) Types.prod List.list -> Bool.bool **) +let rec mem_assoc_env i = function +| List.Nil -> Bool.False +| List.Cons (hd, tl) -> + let { Types.fst = id; Types.snd = ty } = hd in + (match Identifiers.identifier_eq PreIdentifiers.SymbolTag i id with + | Types.Inl _ -> Bool.True + | Types.Inr _ -> mem_assoc_env i tl) + +type 'a lset = 'a List.list + +(** val empty_lset : 'a1 List.list **) +let empty_lset = + List.Nil + +(** val lset_union : 'a1 lset -> 'a1 lset -> 'a1 List.list **) +let lset_union l1 l2 = + List.append l1 l2 + +(** val lset_remove : Deqsets.deqSet -> __ lset -> __ -> __ List.list **) +let lset_remove a l elt = + List.filter (fun x -> Bool.notb (Deqsets.eqb a x elt)) l + +(** val lset_difference : + Deqsets.deqSet -> __ lset -> __ lset -> __ List.list **) +let lset_difference a l1 l2 = + List.filter (fun x -> Bool.notb (Listb.memb a x l2)) l1 + +(** val wF_rect : ('a1 -> __ -> ('a1 -> __ -> 'a2) -> 'a2) -> 'a1 -> 'a2 **) +let rec wF_rect f x = + f x __ (fun y _ -> wF_rect f y) + +(** val one_bv : Nat.nat -> BitVector.bitVector **) +let one_bv n = + (Arithmetic.add_with_carries n (BitVector.zero n) (BitVector.zero n) + Bool.True).Types.fst + +(** val ith_carry : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + Bool.bool **) +let rec ith_carry n a b init = + (match n with + | Nat.O -> (fun x x0 -> init) + | Nat.S x -> + (fun a' b' -> + let hd_a = Vector.head' x a' in + let hd_b = Vector.head' x b' in + let tl_a = Vector.tail x a' in + let tl_b = Vector.tail x b' in + Arithmetic.carry_of hd_a hd_b (ith_carry x tl_a tl_b init))) a b + +(** val ith_bit : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + Bool.bool **) +let ith_bit n a b init = + (match n with + | Nat.O -> (fun x x0 -> init) + | Nat.S x -> + (fun a' b' -> + let hd_a = Vector.head' x a' in + let hd_b = Vector.head' x b' in + let tl_a = Vector.tail x a' in + let tl_b = Vector.tail x b' in + Bool.xorb (Bool.xorb hd_a hd_b) (ith_carry x tl_a tl_b init))) a b + +(** val bitvector_fold : + Nat.nat -> BitVector.bitVector -> (Nat.nat -> BitVector.bitVector -> + Bool.bool) -> BitVector.bitVector **) +let rec bitvector_fold n v f = + match v with + | Vector.VEmpty -> Vector.VEmpty + | Vector.VCons (sz, elt, tl) -> + let bit = f n v in Vector.VCons (sz, bit, (bitvector_fold sz tl f)) + +(** val bitvector_fold2 : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> (Nat.nat -> + BitVector.bitVector -> BitVector.bitVector -> Bool.bool) -> + BitVector.bitVector **) +let rec bitvector_fold2 n v1 v2 f = + (match v1 with + | Vector.VEmpty -> (fun x -> Vector.VEmpty) + | Vector.VCons (sz, elt, tl) -> + (fun v2' -> + let bit = f n v1 v2 in + Vector.VCons (sz, bit, (bitvector_fold2 sz tl (Vector.tail sz v2') f)))) + v2 + +(** val addition_n_direct : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + BitVector.bitVector **) +let addition_n_direct n v1 v2 init = + bitvector_fold2 n v1 v2 (fun n0 v10 v20 -> ith_bit n0 v10 v20 init) + +(** val increment_direct : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let increment_direct n v = + addition_n_direct n v (one_bv n) Bool.False + +(** val twocomp_neg_direct : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let twocomp_neg_direct n v = + increment_direct n (BitVector.negation_bv n v) + +(** val andb_fold : Nat.nat -> BitVector.bitVector -> Bool.bool **) +let rec andb_fold n = function +| Vector.VEmpty -> Bool.True +| Vector.VCons (sz, elt, tl) -> Bool.andb elt (andb_fold sz tl) + diff --git a/extracted/frontend_misc.mli b/extracted/frontend_misc.mli new file mode 100644 index 0000000..01c0323 --- /dev/null +++ b/extracted/frontend_misc.mli @@ -0,0 +1,169 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open Star + +open IOMonad + +open IO + +open Sets + +open Listb + +val typ_eq_dec : AST.typ -> AST.typ -> (__, __) Types.sum + +val block_DeqSet : Deqsets.deqSet + +val mem_assoc_env : + AST.ident -> (AST.ident, Csyntax.type0) Types.prod List.list -> Bool.bool + +type 'a lset = 'a List.list + +val empty_lset : 'a1 List.list + +val lset_union : 'a1 lset -> 'a1 lset -> 'a1 List.list + +val lset_remove : Deqsets.deqSet -> __ lset -> __ -> __ List.list + +val lset_difference : Deqsets.deqSet -> __ lset -> __ lset -> __ List.list + +val wF_rect : ('a1 -> __ -> ('a1 -> __ -> 'a2) -> 'a2) -> 'a1 -> 'a2 + +val one_bv : Nat.nat -> BitVector.bitVector + +val ith_carry : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + Bool.bool + +val ith_bit : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + Bool.bool + +val bitvector_fold : + Nat.nat -> BitVector.bitVector -> (Nat.nat -> BitVector.bitVector -> + Bool.bool) -> BitVector.bitVector + +val bitvector_fold2 : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> (Nat.nat -> + BitVector.bitVector -> BitVector.bitVector -> Bool.bool) -> + BitVector.bitVector + +val addition_n_direct : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector -> Bool.bool -> + BitVector.bitVector + +val increment_direct : Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val twocomp_neg_direct : + Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val andb_fold : Nat.nat -> BitVector.bitVector -> Bool.bool + diff --git a/extracted/genMem.ml b/extracted/genMem.ml new file mode 100644 index 0000000..0e0a331 --- /dev/null +++ b/extracted/genMem.ml @@ -0,0 +1,346 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open Hide + +open ByteValues + +(** val update : Z.z -> 'a1 -> (Z.z -> 'a1) -> Z.z -> 'a1 **) +let update x v f y = + match Z.eqZb y x with + | Bool.True -> v + | Bool.False -> f y + +(** val update_block : + Pointers.block -> 'a1 -> (Pointers.block -> 'a1) -> Pointers.block -> 'a1 **) +let update_block x v f y = + match Pointers.eq_block y x with + | Bool.True -> v + | Bool.False -> f y + +type contentmap = Z.z -> ByteValues.beval + +type block_contents = { low : Z.z; high : Z.z; contents : contentmap } + +(** val block_contents_rect_Type4 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 **) +let rec block_contents_rect_Type4 h_mk_block_contents x_6568 = + let { low = low0; high = high0; contents = contents0 } = x_6568 in + h_mk_block_contents low0 high0 contents0 + +(** val block_contents_rect_Type5 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 **) +let rec block_contents_rect_Type5 h_mk_block_contents x_6570 = + let { low = low0; high = high0; contents = contents0 } = x_6570 in + h_mk_block_contents low0 high0 contents0 + +(** val block_contents_rect_Type3 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 **) +let rec block_contents_rect_Type3 h_mk_block_contents x_6572 = + let { low = low0; high = high0; contents = contents0 } = x_6572 in + h_mk_block_contents low0 high0 contents0 + +(** val block_contents_rect_Type2 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 **) +let rec block_contents_rect_Type2 h_mk_block_contents x_6574 = + let { low = low0; high = high0; contents = contents0 } = x_6574 in + h_mk_block_contents low0 high0 contents0 + +(** val block_contents_rect_Type1 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 **) +let rec block_contents_rect_Type1 h_mk_block_contents x_6576 = + let { low = low0; high = high0; contents = contents0 } = x_6576 in + h_mk_block_contents low0 high0 contents0 + +(** val block_contents_rect_Type0 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 **) +let rec block_contents_rect_Type0 h_mk_block_contents x_6578 = + let { low = low0; high = high0; contents = contents0 } = x_6578 in + h_mk_block_contents low0 high0 contents0 + +(** val low : block_contents -> Z.z **) +let rec low xxx = + xxx.low + +(** val high : block_contents -> Z.z **) +let rec high xxx = + xxx.high + +(** val contents : block_contents -> contentmap **) +let rec contents xxx = + xxx.contents + +(** val block_contents_inv_rect_Type4 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 **) +let block_contents_inv_rect_Type4 hterm h1 = + let hcut = block_contents_rect_Type4 h1 hterm in hcut __ + +(** val block_contents_inv_rect_Type3 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 **) +let block_contents_inv_rect_Type3 hterm h1 = + let hcut = block_contents_rect_Type3 h1 hterm in hcut __ + +(** val block_contents_inv_rect_Type2 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 **) +let block_contents_inv_rect_Type2 hterm h1 = + let hcut = block_contents_rect_Type2 h1 hterm in hcut __ + +(** val block_contents_inv_rect_Type1 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 **) +let block_contents_inv_rect_Type1 hterm h1 = + let hcut = block_contents_rect_Type1 h1 hterm in hcut __ + +(** val block_contents_inv_rect_Type0 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 **) +let block_contents_inv_rect_Type0 hterm h1 = + let hcut = block_contents_rect_Type0 h1 hterm in hcut __ + +(** val block_contents_discr : block_contents -> block_contents -> __ **) +let block_contents_discr x y = + Logic.eq_rect_Type2 x + (let { low = a0; high = a1; contents = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val block_contents_jmdiscr : block_contents -> block_contents -> __ **) +let block_contents_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { low = a0; high = a1; contents = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +type mem = { blocks : (Pointers.block -> block_contents); nextblock : Z.z } + +(** val mem_rect_Type4 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 **) +let rec mem_rect_Type4 h_mk_mem x_6594 = + let { blocks = blocks0; nextblock = nextblock0 } = x_6594 in + h_mk_mem blocks0 nextblock0 __ + +(** val mem_rect_Type5 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 **) +let rec mem_rect_Type5 h_mk_mem x_6596 = + let { blocks = blocks0; nextblock = nextblock0 } = x_6596 in + h_mk_mem blocks0 nextblock0 __ + +(** val mem_rect_Type3 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 **) +let rec mem_rect_Type3 h_mk_mem x_6598 = + let { blocks = blocks0; nextblock = nextblock0 } = x_6598 in + h_mk_mem blocks0 nextblock0 __ + +(** val mem_rect_Type2 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 **) +let rec mem_rect_Type2 h_mk_mem x_6600 = + let { blocks = blocks0; nextblock = nextblock0 } = x_6600 in + h_mk_mem blocks0 nextblock0 __ + +(** val mem_rect_Type1 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 **) +let rec mem_rect_Type1 h_mk_mem x_6602 = + let { blocks = blocks0; nextblock = nextblock0 } = x_6602 in + h_mk_mem blocks0 nextblock0 __ + +(** val mem_rect_Type0 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 **) +let rec mem_rect_Type0 h_mk_mem x_6604 = + let { blocks = blocks0; nextblock = nextblock0 } = x_6604 in + h_mk_mem blocks0 nextblock0 __ + +(** val blocks : mem -> Pointers.block -> block_contents **) +let rec blocks xxx = + xxx.blocks + +(** val nextblock : mem -> Z.z **) +let rec nextblock xxx = + xxx.nextblock + +(** val mem_inv_rect_Type4 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 **) +let mem_inv_rect_Type4 hterm h1 = + let hcut = mem_rect_Type4 h1 hterm in hcut __ + +(** val mem_inv_rect_Type3 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 **) +let mem_inv_rect_Type3 hterm h1 = + let hcut = mem_rect_Type3 h1 hterm in hcut __ + +(** val mem_inv_rect_Type2 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 **) +let mem_inv_rect_Type2 hterm h1 = + let hcut = mem_rect_Type2 h1 hterm in hcut __ + +(** val mem_inv_rect_Type1 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 **) +let mem_inv_rect_Type1 hterm h1 = + let hcut = mem_rect_Type1 h1 hterm in hcut __ + +(** val mem_inv_rect_Type0 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 **) +let mem_inv_rect_Type0 hterm h1 = + let hcut = mem_rect_Type0 h1 hterm in hcut __ + +(** val mem_discr : mem -> mem -> __ **) +let mem_discr x y = + Logic.eq_rect_Type2 x + (let { blocks = a0; nextblock = a1 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val mem_jmdiscr : mem -> mem -> __ **) +let mem_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { blocks = a0; nextblock = a1 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val oneZ : Z.z **) +let oneZ = + Z.Pos Positive.One + +(** val empty_block : Z.z -> Z.z -> block_contents **) +let empty_block lo hi = + { low = lo; high = hi; contents = (fun y -> ByteValues.BVundef) } + +(** val empty : mem **) +let empty = + { blocks = (fun x -> empty_block Z.OZ Z.OZ); nextblock = (Z.Pos + Positive.One) } + +(** val alloc : mem -> Z.z -> Z.z -> (mem, Pointers.block) Types.prod **) +let rec alloc m lo hi = + let b = m.nextblock in + { Types.fst = { blocks = (update_block b (empty_block lo hi) m.blocks); + nextblock = (Z.zsucc m.nextblock) }; Types.snd = b } + +(** val free : mem -> Pointers.block -> mem **) +let free m b = + { blocks = + (update_block b (empty_block (Z.Pos Positive.One) Z.OZ) m.blocks); + nextblock = m.nextblock } + +(** val free_list : mem -> Pointers.block List.list -> mem **) +let free_list m l = + List.foldr (fun b m0 -> free m0 b) m l + +(** val low_bound : mem -> Pointers.block -> Z.z **) +let low_bound m b = + (m.blocks b).low + +(** val high_bound : mem -> Pointers.block -> Z.z **) +let high_bound m b = + (m.blocks b).high + +(** val block_region : mem -> Pointers.block -> AST.region **) +let block_region m b = + Pointers.block_region b + +(** val do_if_in_bounds : + mem -> Pointers.pointer -> (Pointers.block -> block_contents -> Z.z -> + 'a1) -> 'a1 Types.option **) +let do_if_in_bounds m ptr f = + let b = ptr.Pointers.pblock in + (match Z.zltb (Pointers.block_id b) m.nextblock with + | Bool.True -> + let content = m.blocks b in + let off = + BitVectorZ.z_of_unsigned_bitvector Pointers.offset_size + (Pointers.offv ptr.Pointers.poff) + in + (match Bool.andb (Z.zleb content.low off) (Z.zltb off content.high) with + | Bool.True -> Types.Some (f b content off) + | Bool.False -> Types.None) + | Bool.False -> Types.None) + +(** val beloadv : + mem -> Pointers.pointer -> ByteValues.beval Types.option **) +let beloadv m ptr = + do_if_in_bounds m ptr (fun b content off -> content.contents off) + +(** val bestorev : + mem -> Pointers.pointer -> ByteValues.beval -> mem Types.option **) +let bestorev m ptr v = + do_if_in_bounds m ptr (fun b content off -> + let contents0 = update off v content.contents in + let content0 = { low = content.low; high = content.high; contents = + contents0 } + in + let blocks0 = update_block b content0 m.blocks in + { blocks = blocks0; nextblock = m.nextblock }) + diff --git a/extracted/genMem.mli b/extracted/genMem.mli new file mode 100644 index 0000000..bf8884d --- /dev/null +++ b/extracted/genMem.mli @@ -0,0 +1,209 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open Hide + +open ByteValues + +val update : Z.z -> 'a1 -> (Z.z -> 'a1) -> Z.z -> 'a1 + +val update_block : + Pointers.block -> 'a1 -> (Pointers.block -> 'a1) -> Pointers.block -> 'a1 + +type contentmap = Z.z -> ByteValues.beval + +type block_contents = { low : Z.z; high : Z.z; contents : contentmap } + +val block_contents_rect_Type4 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 + +val block_contents_rect_Type5 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 + +val block_contents_rect_Type3 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 + +val block_contents_rect_Type2 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 + +val block_contents_rect_Type1 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 + +val block_contents_rect_Type0 : + (Z.z -> Z.z -> contentmap -> 'a1) -> block_contents -> 'a1 + +val low : block_contents -> Z.z + +val high : block_contents -> Z.z + +val contents : block_contents -> contentmap + +val block_contents_inv_rect_Type4 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 + +val block_contents_inv_rect_Type3 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 + +val block_contents_inv_rect_Type2 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 + +val block_contents_inv_rect_Type1 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 + +val block_contents_inv_rect_Type0 : + block_contents -> (Z.z -> Z.z -> contentmap -> __ -> 'a1) -> 'a1 + +val block_contents_discr : block_contents -> block_contents -> __ + +val block_contents_jmdiscr : block_contents -> block_contents -> __ + +type mem = { blocks : (Pointers.block -> block_contents); nextblock : Z.z } + +val mem_rect_Type4 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 + +val mem_rect_Type5 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 + +val mem_rect_Type3 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 + +val mem_rect_Type2 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 + +val mem_rect_Type1 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 + +val mem_rect_Type0 : + ((Pointers.block -> block_contents) -> Z.z -> __ -> 'a1) -> mem -> 'a1 + +val blocks : mem -> Pointers.block -> block_contents + +val nextblock : mem -> Z.z + +val mem_inv_rect_Type4 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 + +val mem_inv_rect_Type3 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 + +val mem_inv_rect_Type2 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 + +val mem_inv_rect_Type1 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 + +val mem_inv_rect_Type0 : + mem -> ((Pointers.block -> block_contents) -> Z.z -> __ -> __ -> 'a1) -> + 'a1 + +val mem_discr : mem -> mem -> __ + +val mem_jmdiscr : mem -> mem -> __ + +val oneZ : Z.z + +val empty_block : Z.z -> Z.z -> block_contents + +val empty : mem + +val alloc : mem -> Z.z -> Z.z -> (mem, Pointers.block) Types.prod + +val free : mem -> Pointers.block -> mem + +val free_list : mem -> Pointers.block List.list -> mem + +val low_bound : mem -> Pointers.block -> Z.z + +val high_bound : mem -> Pointers.block -> Z.z + +val block_region : mem -> Pointers.block -> AST.region + +val do_if_in_bounds : + mem -> Pointers.pointer -> (Pointers.block -> block_contents -> Z.z -> 'a1) + -> 'a1 Types.option + +val beloadv : mem -> Pointers.pointer -> ByteValues.beval Types.option + +val bestorev : + mem -> Pointers.pointer -> ByteValues.beval -> mem Types.option + diff --git a/extracted/globalenvs.ml b/extracted/globalenvs.ml new file mode 100644 index 0000000..1ae2aa3 --- /dev/null +++ b/extracted/globalenvs.ml @@ -0,0 +1,737 @@ +open Preamble + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +type 'f genv_t = { functions : 'f PositiveMap.positive_map; + nextfunction : Positive.pos; + symbols : Pointers.block Identifiers.identifier_map } + +(** val genv_t_rect_Type4 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 **) +let rec genv_t_rect_Type4 h_mk_genv_t x_6621 = + let { functions = functions0; nextfunction = nextfunction0; symbols = + symbols0 } = x_6621 + in + h_mk_genv_t functions0 nextfunction0 symbols0 __ + +(** val genv_t_rect_Type5 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 **) +let rec genv_t_rect_Type5 h_mk_genv_t x_6623 = + let { functions = functions0; nextfunction = nextfunction0; symbols = + symbols0 } = x_6623 + in + h_mk_genv_t functions0 nextfunction0 symbols0 __ + +(** val genv_t_rect_Type3 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 **) +let rec genv_t_rect_Type3 h_mk_genv_t x_6625 = + let { functions = functions0; nextfunction = nextfunction0; symbols = + symbols0 } = x_6625 + in + h_mk_genv_t functions0 nextfunction0 symbols0 __ + +(** val genv_t_rect_Type2 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 **) +let rec genv_t_rect_Type2 h_mk_genv_t x_6627 = + let { functions = functions0; nextfunction = nextfunction0; symbols = + symbols0 } = x_6627 + in + h_mk_genv_t functions0 nextfunction0 symbols0 __ + +(** val genv_t_rect_Type1 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 **) +let rec genv_t_rect_Type1 h_mk_genv_t x_6629 = + let { functions = functions0; nextfunction = nextfunction0; symbols = + symbols0 } = x_6629 + in + h_mk_genv_t functions0 nextfunction0 symbols0 __ + +(** val genv_t_rect_Type0 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 **) +let rec genv_t_rect_Type0 h_mk_genv_t x_6631 = + let { functions = functions0; nextfunction = nextfunction0; symbols = + symbols0 } = x_6631 + in + h_mk_genv_t functions0 nextfunction0 symbols0 __ + +(** val functions : 'a1 genv_t -> 'a1 PositiveMap.positive_map **) +let rec functions xxx = + xxx.functions + +(** val nextfunction : 'a1 genv_t -> Positive.pos **) +let rec nextfunction xxx = + xxx.nextfunction + +(** val symbols : 'a1 genv_t -> Pointers.block Identifiers.identifier_map **) +let rec symbols xxx = + xxx.symbols + +(** val genv_t_inv_rect_Type4 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 **) +let genv_t_inv_rect_Type4 hterm h1 = + let hcut = genv_t_rect_Type4 h1 hterm in hcut __ + +(** val genv_t_inv_rect_Type3 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 **) +let genv_t_inv_rect_Type3 hterm h1 = + let hcut = genv_t_rect_Type3 h1 hterm in hcut __ + +(** val genv_t_inv_rect_Type2 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 **) +let genv_t_inv_rect_Type2 hterm h1 = + let hcut = genv_t_rect_Type2 h1 hterm in hcut __ + +(** val genv_t_inv_rect_Type1 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 **) +let genv_t_inv_rect_Type1 hterm h1 = + let hcut = genv_t_rect_Type1 h1 hterm in hcut __ + +(** val genv_t_inv_rect_Type0 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 **) +let genv_t_inv_rect_Type0 hterm h1 = + let hcut = genv_t_rect_Type0 h1 hterm in hcut __ + +(** val genv_t_discr : 'a1 genv_t -> 'a1 genv_t -> __ **) +let genv_t_discr x y = + Logic.eq_rect_Type2 x + (let { functions = a0; nextfunction = a10; symbols = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val genv_t_jmdiscr : 'a1 genv_t -> 'a1 genv_t -> __ **) +let genv_t_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { functions = a0; nextfunction = a10; symbols = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val drop_fn : AST.ident -> 'a1 genv_t -> 'a1 genv_t **) +let drop_fn id g = + let fns = + match Identifiers.lookup PreIdentifiers.SymbolTag g.symbols id with + | Types.None -> g.functions + | Types.Some b' -> + (match Pointers.block_id b' with + | Z.OZ -> g.functions + | Z.Pos x -> g.functions + | Z.Neg p -> PositiveMap.pm_set p Types.None g.functions) + in + { functions = fns; nextfunction = g.nextfunction; symbols = + (Identifiers.remove PreIdentifiers.SymbolTag g.symbols id) } + +(** val add_funct : + (AST.ident, 'a1) Types.prod -> 'a1 genv_t -> 'a1 genv_t **) +let add_funct name_fun g = + let blk_id = g.nextfunction in + let b = Z.Neg blk_id in + let g' = drop_fn name_fun.Types.fst g in + { functions = (PositiveMap.insert blk_id name_fun.Types.snd g'.functions); + nextfunction = (Positive.succ blk_id); symbols = + (Identifiers.add PreIdentifiers.SymbolTag g'.symbols name_fun.Types.fst b) } + +(** val add_symbol : + AST.ident -> Pointers.block -> 'a1 genv_t -> 'a1 genv_t **) +let add_symbol name b g = + let g' = drop_fn name g in + { functions = g'.functions; nextfunction = g'.nextfunction; symbols = + (Identifiers.add PreIdentifiers.SymbolTag g'.symbols name b) } + +(** val empty_mem : GenMem.mem **) +let empty_mem = + GenMem.empty + +(** val empty : 'a1 genv_t **) +let empty = + { functions = PositiveMap.Pm_leaf; nextfunction = + (Positive.succ_pos_of_nat (Nat.S (Nat.S Nat.O))); symbols = + (Identifiers.empty_map PreIdentifiers.SymbolTag) } + +(** val add_functs : + 'a1 genv_t -> (AST.ident, 'a1) Types.prod List.list -> 'a1 genv_t **) +let add_functs init fns = + List.foldr add_funct init fns + +(** val find_symbol : + 'a1 genv_t -> AST.ident -> Pointers.block Types.option **) +let find_symbol ge = + Identifiers.lookup PreIdentifiers.SymbolTag ge.symbols + +(** val store_init_data : + 'a1 genv_t -> GenMem.mem -> Pointers.block -> Z.z -> AST.init_data -> + GenMem.mem Types.option **) +let store_init_data ge m b p id = + let ptr = { Pointers.pblock = b; Pointers.poff = + (BitVectorZ.bitvector_of_Z Pointers.offset_size p) } + in + (match id with + | AST.Init_int8 n -> + FrontEndMem.store (AST.ASTint (AST.I8, AST.Unsigned)) m ptr (Values.Vint + (AST.I8, n)) + | AST.Init_int16 n -> + FrontEndMem.store (AST.ASTint (AST.I16, AST.Unsigned)) m ptr + (Values.Vint (AST.I16, n)) + | AST.Init_int32 n -> + FrontEndMem.store (AST.ASTint (AST.I32, AST.Unsigned)) m ptr + (Values.Vint (AST.I32, n)) + | AST.Init_space n -> Types.Some m + | AST.Init_null -> FrontEndMem.store AST.ASTptr m ptr Values.Vnull + | AST.Init_addrof (symb, ofs) -> + (match find_symbol ge symb with + | Types.None -> Types.None + | Types.Some b' -> + FrontEndMem.store AST.ASTptr m ptr (Values.Vptr { Pointers.pblock = + b'; Pointers.poff = + (Pointers.shift_offset (AST.bitsize_of_intsize AST.I16) + Pointers.zero_offset (AST.repr AST.I16 ofs)) }))) + +(** val size_init_data : AST.init_data -> Nat.nat **) +let size_init_data = function +| AST.Init_int8 x -> Nat.S Nat.O +| AST.Init_int16 x -> Nat.S (Nat.S Nat.O) +| AST.Init_int32 x -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O))) +| AST.Init_space n -> Nat.max n Nat.O +| AST.Init_null -> AST.size_pointer +| AST.Init_addrof (x, x0) -> AST.size_pointer + +(** val store_init_data_list : + 'a1 genv_t -> GenMem.mem -> Pointers.block -> Z.z -> AST.init_data + List.list -> GenMem.mem Types.option **) +let rec store_init_data_list ge m b p = function +| List.Nil -> Types.Some m +| List.Cons (id, idl') -> + (match store_init_data ge m b p id with + | Types.None -> Types.None + | Types.Some m' -> + store_init_data_list ge m' b + (Z.zplus p (Z.z_of_nat (size_init_data id))) idl') + +(** val size_init_data_list : AST.init_data List.list -> Nat.nat **) +let size_init_data_list i_data = + List.foldr (fun i_data0 sz -> Nat.plus (size_init_data i_data0) sz) Nat.O + i_data + +(** val add_globals : + ('a2 -> AST.init_data List.list) -> ('a1 genv_t, GenMem.mem) Types.prod + -> ((AST.ident, AST.region) Types.prod, 'a2) Types.prod List.list -> ('a1 + genv_t, GenMem.mem) Types.prod **) +let add_globals extract_init init_env vars = + Util.foldl (fun g_st id_init -> + let { Types.fst = eta1345; Types.snd = init_info } = id_init in + let { Types.fst = id; Types.snd = r } = eta1345 in + let init = extract_init init_info in + let { Types.fst = g; Types.snd = st } = g_st in + let { Types.fst = st'; Types.snd = b } = + GenMem.alloc st Z.OZ (Z.z_of_nat (size_init_data_list init)) + in + let g' = add_symbol id b g in { Types.fst = g'; Types.snd = st' }) + init_env vars + +(** val init_globals : + ('a2 -> AST.init_data List.list) -> 'a1 genv_t -> GenMem.mem -> + ((AST.ident, AST.region) Types.prod, 'a2) Types.prod List.list -> + GenMem.mem Errors.res **) +let init_globals extract_init g m vars = + Util.foldl (fun st id_init -> + let { Types.fst = eta1346; Types.snd = init_info } = id_init in + let { Types.fst = id; Types.snd = r } = eta1346 in + let init = extract_init init_info in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic st) (fun st0 -> + match find_symbol g id with + | Types.None -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.InitDataStoreFailed)) + | Types.Some b -> + Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.InitDataStoreFailed) + (store_init_data_list g st0 b Z.OZ init))))) (Errors.OK m) vars + +(** val globalenv_allocmem : + ('a2 -> AST.init_data List.list) -> ('a1, 'a2) AST.program -> ('a1 + genv_t, GenMem.mem) Types.prod **) +let globalenv_allocmem init_info p = + add_globals init_info { Types.fst = (add_functs empty p.AST.prog_funct); + Types.snd = empty_mem } p.AST.prog_vars + +(** val globalenv : + ('a2 -> AST.init_data List.list) -> ('a1, 'a2) AST.program -> 'a1 genv_t **) +let globalenv i p = + (globalenv_allocmem i p).Types.fst + +(** val globalenv_noinit : ('a1, Nat.nat) AST.program -> 'a1 genv_t **) +let globalenv_noinit p = + globalenv (fun n -> List.Cons ((AST.Init_space n), List.Nil)) p + +(** val init_mem : + ('a2 -> AST.init_data List.list) -> ('a1, 'a2) AST.program -> GenMem.mem + Errors.res **) +let init_mem i p = + let { Types.fst = g; Types.snd = m } = globalenv_allocmem i p in + init_globals i g m p.AST.prog_vars + +(** val alloc_mem : ('a1, Nat.nat) AST.program -> GenMem.mem **) +let alloc_mem p = + (globalenv_allocmem (fun n -> List.Cons ((AST.Init_space n), List.Nil)) p).Types.snd + +(** val find_funct_ptr : 'a1 genv_t -> Pointers.block -> 'a1 Types.option **) +let find_funct_ptr ge b = + match Pointers.block_region b with + | AST.XData -> Types.None + | AST.Code -> + (match Pointers.block_id b with + | Z.OZ -> Types.None + | Z.Pos x -> Types.None + | Z.Neg p -> PositiveMap.lookup_opt p ge.functions) + +(** val find_funct : 'a1 genv_t -> Values.val0 -> 'a1 Types.option **) +let find_funct ge = function +| Values.Vundef -> Types.None +| Values.Vint (x, x0) -> Types.None +| Values.Vnull -> Types.None +| Values.Vptr ptr -> + (match Pointers.eq_offset ptr.Pointers.poff Pointers.zero_offset with + | Bool.True -> find_funct_ptr ge ptr.Pointers.pblock + | Bool.False -> Types.None) + +(** val symbol_for_block : + 'a1 genv_t -> Pointers.block -> AST.ident Types.option **) +let symbol_for_block genv b = + Types.option_map Types.fst + (Identifiers.find PreIdentifiers.SymbolTag genv.symbols (fun id b' -> + Pointers.eq_block b b')) + +(** val symbol_of_function_block : + 'a1 genv_t -> Pointers.block -> AST.ident **) +let symbol_of_function_block ge b = + (match symbol_for_block ge b with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some id -> (fun _ -> id)) __ + +(** val symbol_of_function_block' : + 'a1 genv_t -> Pointers.block -> 'a1 -> AST.ident **) +let symbol_of_function_block' ge b f = + symbol_of_function_block ge b + +(** val find_funct_ptr_id : + 'a1 genv_t -> Pointers.block -> ('a1, AST.ident) Types.prod Types.option **) +let find_funct_ptr_id ge b = + (match find_funct_ptr ge b with + | Types.None -> (fun _ -> Types.None) + | Types.Some f -> + (fun _ -> Types.Some { Types.fst = f; Types.snd = + (symbol_of_function_block' ge b f) })) __ + +(** val opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 **) +let opt_eq_from_res__o__ffpi_drop__o__inject x0 x2 x3 x4 x5 = + __ + +(** val dpi1__o__opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, + 'a2) Types.dPair -> __ Types.sig0 **) +let dpi1__o__opt_eq_from_res__o__ffpi_drop__o__inject x0 x2 x3 x4 x5 x8 = + __ + +(** val eject__o__opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 -> __ Types.sig0 **) +let eject__o__opt_eq_from_res__o__ffpi_drop__o__inject x0 x2 x3 x4 x5 x8 = + __ + +(** val jmeq_to_eq__o__ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 **) +let jmeq_to_eq__o__ffpi_drop__o__inject x1 x2 x3 x4 = + __ + +(** val jmeq_to_eq__o__opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 **) +let jmeq_to_eq__o__opt_eq_from_res__o__ffpi_drop__o__inject x0 x2 x3 x4 x5 = + __ + +(** val dpi1__o__ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, 'a2) Types.dPair + -> __ Types.sig0 **) +let dpi1__o__ffpi_drop__o__inject x1 x2 x3 x4 x7 = + __ + +(** val eject__o__ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 -> __ + Types.sig0 **) +let eject__o__ffpi_drop__o__inject x1 x2 x3 x4 x7 = + __ + +(** val ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 **) +let ffpi_drop__o__inject x1 x2 x3 x4 = + __ + +(** val symbol_of_function_val : 'a1 genv_t -> Values.val0 -> AST.ident **) +let symbol_of_function_val ge v = + (match v with + | Values.Vundef -> (fun _ -> assert false (* absurd case *)) + | Values.Vint (x, x0) -> (fun _ -> assert false (* absurd case *)) + | Values.Vnull -> (fun _ -> assert false (* absurd case *)) + | Values.Vptr p -> + (fun _ -> symbol_of_function_block ge p.Pointers.pblock)) __ + +(** val symbol_of_function_val' : + 'a1 genv_t -> Values.val0 -> 'a1 -> AST.ident **) +let symbol_of_function_val' ge v f = + symbol_of_function_val ge v + +(** val find_funct_id : + 'a1 genv_t -> Values.val0 -> ('a1, AST.ident) Types.prod Types.option **) +let find_funct_id ge v = + (match find_funct ge v with + | Types.None -> (fun _ -> Types.None) + | Types.Some f -> + (fun _ -> Types.Some { Types.fst = f; Types.snd = + (symbol_of_function_val' ge v f) })) __ + +(** val opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 **) +let opt_eq_from_res__o__ffi_drop__o__inject x0 x2 x3 x4 x5 = + __ + +(** val dpi1__o__opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, + 'a2) Types.dPair -> __ Types.sig0 **) +let dpi1__o__opt_eq_from_res__o__ffi_drop__o__inject x0 x2 x3 x4 x5 x8 = + __ + +(** val eject__o__opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 -> __ Types.sig0 **) +let eject__o__opt_eq_from_res__o__ffi_drop__o__inject x0 x2 x3 x4 x5 x8 = + __ + +(** val jmeq_to_eq__o__ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 **) +let jmeq_to_eq__o__ffi_drop__o__inject x1 x2 x3 x4 = + __ + +(** val jmeq_to_eq__o__opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 **) +let jmeq_to_eq__o__opt_eq_from_res__o__ffi_drop__o__inject x0 x2 x3 x4 x5 = + __ + +(** val dpi1__o__ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, 'a2) Types.dPair -> + __ Types.sig0 **) +let dpi1__o__ffi_drop__o__inject x1 x2 x3 x4 x7 = + __ + +(** val eject__o__ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 -> __ + Types.sig0 **) +let eject__o__ffi_drop__o__inject x1 x2 x3 x4 x7 = + __ + +(** val ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 **) +let ffi_drop__o__inject x1 x2 x3 x4 = + __ + +(** val nat_plus_pos : Nat.nat -> Positive.pos -> Positive.pos **) +let rec nat_plus_pos n p = + match n with + | Nat.O -> p + | Nat.S m -> Positive.succ (nat_plus_pos m p) + +(** val alloc_pair : + GenMem.mem -> GenMem.mem -> Z.z -> Z.z -> Z.z -> Z.z -> (GenMem.mem -> + GenMem.mem -> Pointers.block -> __ -> 'a1) -> 'a1 **) +let alloc_pair clearme m' l h l' h' x = + (let { GenMem.blocks = ct; GenMem.nextblock = nx } = clearme in + (fun clearme0 -> + let { GenMem.blocks = ct'; GenMem.nextblock = nx' } = clearme0 in + (fun l0 h0 l'0 h'0 _ _ -> + Extralib.eq_rect_Type0_r nx' (fun _ h1 -> + h1 { GenMem.blocks = + (GenMem.update_block { GenMem.blocks = ct; GenMem.nextblock = + nx' }.GenMem.nextblock (GenMem.empty_block l0 h0) { GenMem.blocks = + ct; GenMem.nextblock = nx' }.GenMem.blocks); GenMem.nextblock = + (Z.zsucc { GenMem.blocks = ct; GenMem.nextblock = + nx' }.GenMem.nextblock) } { GenMem.blocks = + (GenMem.update_block { GenMem.blocks = ct'; GenMem.nextblock = + nx' }.GenMem.nextblock (GenMem.empty_block l'0 h'0) { GenMem.blocks = + ct'; GenMem.nextblock = nx' }.GenMem.blocks); GenMem.nextblock = + (Z.zsucc { GenMem.blocks = ct'; GenMem.nextblock = + nx' }.GenMem.nextblock) } { GenMem.blocks = ct; GenMem.nextblock = + nx' }.GenMem.nextblock __) nx __))) m' l h l' h' __ __ x + +(** val prod_jmdiscr : + ('a1, 'a2) Types.prod -> ('a1, 'a2) Types.prod -> __ **) +let prod_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { Types.fst = a0; Types.snd = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val related_globals_rect_Type4 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 **) +let rec related_globals_rect_Type4 t ge ge' h_mk_related_globals = + h_mk_related_globals __ __ __ __ + +(** val related_globals_rect_Type5 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 **) +let rec related_globals_rect_Type5 t ge ge' h_mk_related_globals = + h_mk_related_globals __ __ __ __ + +(** val related_globals_rect_Type3 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 **) +let rec related_globals_rect_Type3 t ge ge' h_mk_related_globals = + h_mk_related_globals __ __ __ __ + +(** val related_globals_rect_Type2 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 **) +let rec related_globals_rect_Type2 t ge ge' h_mk_related_globals = + h_mk_related_globals __ __ __ __ + +(** val related_globals_rect_Type1 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 **) +let rec related_globals_rect_Type1 t ge ge' h_mk_related_globals = + h_mk_related_globals __ __ __ __ + +(** val related_globals_rect_Type0 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 **) +let rec related_globals_rect_Type0 t ge ge' h_mk_related_globals = + h_mk_related_globals __ __ __ __ + +(** val related_globals_inv_rect_Type4 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ + -> 'a3) -> 'a3 **) +let related_globals_inv_rect_Type4 x3 x4 x5 h1 = + let hcut = related_globals_rect_Type4 x3 x4 x5 h1 in hcut __ + +(** val related_globals_inv_rect_Type3 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ + -> 'a3) -> 'a3 **) +let related_globals_inv_rect_Type3 x3 x4 x5 h1 = + let hcut = related_globals_rect_Type3 x3 x4 x5 h1 in hcut __ + +(** val related_globals_inv_rect_Type2 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ + -> 'a3) -> 'a3 **) +let related_globals_inv_rect_Type2 x3 x4 x5 h1 = + let hcut = related_globals_rect_Type2 x3 x4 x5 h1 in hcut __ + +(** val related_globals_inv_rect_Type1 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ + -> 'a3) -> 'a3 **) +let related_globals_inv_rect_Type1 x3 x4 x5 h1 = + let hcut = related_globals_rect_Type1 x3 x4 x5 h1 in hcut __ + +(** val related_globals_inv_rect_Type0 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ + -> 'a3) -> 'a3 **) +let related_globals_inv_rect_Type0 x3 x4 x5 h1 = + let hcut = related_globals_rect_Type0 x3 x4 x5 h1 in hcut __ + +(** val related_globals_discr : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> __ **) +let related_globals_discr a3 a4 a5 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __ __)) __ + +(** val related_globals_jmdiscr : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> __ **) +let related_globals_jmdiscr a3 a4 a5 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __ __)) __ + +(** val related_globals_gen_rect_Type4 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> 'a3) -> 'a3 **) +let rec related_globals_gen_rect_Type4 tag t ge ge' h_mk_related_globals_gen = + h_mk_related_globals_gen __ __ __ __ + +(** val related_globals_gen_rect_Type5 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> 'a3) -> 'a3 **) +let rec related_globals_gen_rect_Type5 tag t ge ge' h_mk_related_globals_gen = + h_mk_related_globals_gen __ __ __ __ + +(** val related_globals_gen_rect_Type3 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> 'a3) -> 'a3 **) +let rec related_globals_gen_rect_Type3 tag t ge ge' h_mk_related_globals_gen = + h_mk_related_globals_gen __ __ __ __ + +(** val related_globals_gen_rect_Type2 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> 'a3) -> 'a3 **) +let rec related_globals_gen_rect_Type2 tag t ge ge' h_mk_related_globals_gen = + h_mk_related_globals_gen __ __ __ __ + +(** val related_globals_gen_rect_Type1 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> 'a3) -> 'a3 **) +let rec related_globals_gen_rect_Type1 tag t ge ge' h_mk_related_globals_gen = + h_mk_related_globals_gen __ __ __ __ + +(** val related_globals_gen_rect_Type0 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> 'a3) -> 'a3 **) +let rec related_globals_gen_rect_Type0 tag t ge ge' h_mk_related_globals_gen = + h_mk_related_globals_gen __ __ __ __ + +(** val related_globals_gen_inv_rect_Type4 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let related_globals_gen_inv_rect_Type4 x1 x4 x5 x6 h1 = + let hcut = related_globals_gen_rect_Type4 x1 x4 x5 x6 h1 in hcut __ + +(** val related_globals_gen_inv_rect_Type3 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let related_globals_gen_inv_rect_Type3 x1 x4 x5 x6 h1 = + let hcut = related_globals_gen_rect_Type3 x1 x4 x5 x6 h1 in hcut __ + +(** val related_globals_gen_inv_rect_Type2 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let related_globals_gen_inv_rect_Type2 x1 x4 x5 x6 h1 = + let hcut = related_globals_gen_rect_Type2 x1 x4 x5 x6 h1 in hcut __ + +(** val related_globals_gen_inv_rect_Type1 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let related_globals_gen_inv_rect_Type1 x1 x4 x5 x6 h1 = + let hcut = related_globals_gen_rect_Type1 x1 x4 x5 x6 h1 in hcut __ + +(** val related_globals_gen_inv_rect_Type0 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> + __ -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let related_globals_gen_inv_rect_Type0 x1 x4 x5 x6 h1 = + let hcut = related_globals_gen_rect_Type0 x1 x4 x5 x6 h1 in hcut __ + +(** val related_globals_gen_discr : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> __ **) +let related_globals_gen_discr a1 a4 a5 a6 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __ __)) __ + +(** val related_globals_gen_jmdiscr : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> __ **) +let related_globals_gen_jmdiscr a1 a4 a5 a6 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __ __)) __ + +open Extra_bool + diff --git a/extracted/globalenvs.mli b/extracted/globalenvs.mli new file mode 100644 index 0000000..f4ffbcc --- /dev/null +++ b/extracted/globalenvs.mli @@ -0,0 +1,404 @@ +open Preamble + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +type 'f genv_t = { functions : 'f PositiveMap.positive_map; + nextfunction : Positive.pos; + symbols : Pointers.block Identifiers.identifier_map } + +val genv_t_rect_Type4 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 + +val genv_t_rect_Type5 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 + +val genv_t_rect_Type3 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 + +val genv_t_rect_Type2 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 + +val genv_t_rect_Type1 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 + +val genv_t_rect_Type0 : + ('a1 PositiveMap.positive_map -> Positive.pos -> Pointers.block + Identifiers.identifier_map -> __ -> 'a2) -> 'a1 genv_t -> 'a2 + +val functions : 'a1 genv_t -> 'a1 PositiveMap.positive_map + +val nextfunction : 'a1 genv_t -> Positive.pos + +val symbols : 'a1 genv_t -> Pointers.block Identifiers.identifier_map + +val genv_t_inv_rect_Type4 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 + +val genv_t_inv_rect_Type3 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 + +val genv_t_inv_rect_Type2 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 + +val genv_t_inv_rect_Type1 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 + +val genv_t_inv_rect_Type0 : + 'a1 genv_t -> ('a1 PositiveMap.positive_map -> Positive.pos -> + Pointers.block Identifiers.identifier_map -> __ -> __ -> 'a2) -> 'a2 + +val genv_t_discr : 'a1 genv_t -> 'a1 genv_t -> __ + +val genv_t_jmdiscr : 'a1 genv_t -> 'a1 genv_t -> __ + +val drop_fn : AST.ident -> 'a1 genv_t -> 'a1 genv_t + +val add_funct : (AST.ident, 'a1) Types.prod -> 'a1 genv_t -> 'a1 genv_t + +val add_symbol : AST.ident -> Pointers.block -> 'a1 genv_t -> 'a1 genv_t + +val empty_mem : GenMem.mem + +val empty : 'a1 genv_t + +val add_functs : + 'a1 genv_t -> (AST.ident, 'a1) Types.prod List.list -> 'a1 genv_t + +val find_symbol : 'a1 genv_t -> AST.ident -> Pointers.block Types.option + +val store_init_data : + 'a1 genv_t -> GenMem.mem -> Pointers.block -> Z.z -> AST.init_data -> + GenMem.mem Types.option + +val size_init_data : AST.init_data -> Nat.nat + +val store_init_data_list : + 'a1 genv_t -> GenMem.mem -> Pointers.block -> Z.z -> AST.init_data + List.list -> GenMem.mem Types.option + +val size_init_data_list : AST.init_data List.list -> Nat.nat + +val add_globals : + ('a2 -> AST.init_data List.list) -> ('a1 genv_t, GenMem.mem) Types.prod -> + ((AST.ident, AST.region) Types.prod, 'a2) Types.prod List.list -> ('a1 + genv_t, GenMem.mem) Types.prod + +val init_globals : + ('a2 -> AST.init_data List.list) -> 'a1 genv_t -> GenMem.mem -> + ((AST.ident, AST.region) Types.prod, 'a2) Types.prod List.list -> + GenMem.mem Errors.res + +val globalenv_allocmem : + ('a2 -> AST.init_data List.list) -> ('a1, 'a2) AST.program -> ('a1 genv_t, + GenMem.mem) Types.prod + +val globalenv : + ('a2 -> AST.init_data List.list) -> ('a1, 'a2) AST.program -> 'a1 genv_t + +val globalenv_noinit : ('a1, Nat.nat) AST.program -> 'a1 genv_t + +val init_mem : + ('a2 -> AST.init_data List.list) -> ('a1, 'a2) AST.program -> GenMem.mem + Errors.res + +val alloc_mem : ('a1, Nat.nat) AST.program -> GenMem.mem + +val find_funct_ptr : 'a1 genv_t -> Pointers.block -> 'a1 Types.option + +val find_funct : 'a1 genv_t -> Values.val0 -> 'a1 Types.option + +val symbol_for_block : 'a1 genv_t -> Pointers.block -> AST.ident Types.option + +val symbol_of_function_block : 'a1 genv_t -> Pointers.block -> AST.ident + +val symbol_of_function_block' : + 'a1 genv_t -> Pointers.block -> 'a1 -> AST.ident + +val find_funct_ptr_id : + 'a1 genv_t -> Pointers.block -> ('a1, AST.ident) Types.prod Types.option + +val opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 + +val dpi1__o__opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, + 'a2) Types.dPair -> __ Types.sig0 + +val eject__o__opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 -> __ Types.sig0 + +val jmeq_to_eq__o__ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 + +val jmeq_to_eq__o__opt_eq_from_res__o__ffpi_drop__o__inject : + Errors.errmsg -> Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 + +val dpi1__o__ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, 'a2) Types.dPair + -> __ Types.sig0 + +val eject__o__ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 -> __ + Types.sig0 + +val ffpi_drop__o__inject : + Pointers.block -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 + +val symbol_of_function_val : 'a1 genv_t -> Values.val0 -> AST.ident + +val symbol_of_function_val' : 'a1 genv_t -> Values.val0 -> 'a1 -> AST.ident + +val find_funct_id : + 'a1 genv_t -> Values.val0 -> ('a1, AST.ident) Types.prod Types.option + +val opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 + +val dpi1__o__opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, 'a2) + Types.dPair -> __ Types.sig0 + +val eject__o__opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 -> __ Types.sig0 + +val jmeq_to_eq__o__ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 + +val jmeq_to_eq__o__opt_eq_from_res__o__ffi_drop__o__inject : + Errors.errmsg -> Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ + Types.sig0 + +val dpi1__o__ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> (__, 'a2) Types.dPair -> + __ Types.sig0 + +val eject__o__ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 -> __ + Types.sig0 + +val ffi_drop__o__inject : + Values.val0 -> AST.ident -> 'a1 genv_t -> 'a1 -> __ Types.sig0 + +val nat_plus_pos : Nat.nat -> Positive.pos -> Positive.pos + +val alloc_pair : + GenMem.mem -> GenMem.mem -> Z.z -> Z.z -> Z.z -> Z.z -> (GenMem.mem -> + GenMem.mem -> Pointers.block -> __ -> 'a1) -> 'a1 + +val prod_jmdiscr : ('a1, 'a2) Types.prod -> ('a1, 'a2) Types.prod -> __ + +val related_globals_rect_Type4 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 + +val related_globals_rect_Type5 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 + +val related_globals_rect_Type3 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 + +val related_globals_rect_Type2 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 + +val related_globals_rect_Type1 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 + +val related_globals_rect_Type0 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> 'a3) + -> 'a3 + +val related_globals_inv_rect_Type4 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ -> + 'a3) -> 'a3 + +val related_globals_inv_rect_Type3 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ -> + 'a3) -> 'a3 + +val related_globals_inv_rect_Type2 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ -> + 'a3) -> 'a3 + +val related_globals_inv_rect_Type1 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ -> + 'a3) -> 'a3 + +val related_globals_inv_rect_Type0 : + ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ -> __ -> __ -> __ -> + 'a3) -> 'a3 + +val related_globals_discr : ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> __ + +val related_globals_jmdiscr : ('a1 -> 'a2) -> 'a1 genv_t -> 'a2 genv_t -> __ + +val related_globals_gen_rect_Type4 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_rect_Type5 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_rect_Type3 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_rect_Type2 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_rect_Type1 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_rect_Type0 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_inv_rect_Type4 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_inv_rect_Type3 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_inv_rect_Type2 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_inv_rect_Type1 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_inv_rect_Type0 : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> (__ -> __ + -> __ -> __ -> __ -> 'a3) -> 'a3 + +val related_globals_gen_discr : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> __ + +val related_globals_gen_jmdiscr : + PreIdentifiers.identifierTag -> (Identifiers.universe -> 'a1 -> ('a2, + Identifiers.universe) Types.prod) -> 'a1 genv_t -> 'a2 genv_t -> __ + +open Extra_bool + diff --git a/extracted/graphs.ml b/extracted/graphs.ml new file mode 100644 index 0000000..d92a575 --- /dev/null +++ b/extracted/graphs.ml @@ -0,0 +1,93 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open BitVectorTrie + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Integers + +open AST + +type label = PreIdentifiers.identifier + +(** val label_to_ident : label -> AST.ident **) +let label_to_ident l = + let l0 = l in l0 + +(** val label_eq : label -> label -> (__, __) Types.sum **) +let label_eq = + Identifiers.identifier_eq PreIdentifiers.LabelTag + +type 'x graph = 'x Identifiers.identifier_map + +(** val graph_fold : + (Positive.pos -> 'a1 -> 'a2 -> 'a2) -> 'a1 graph -> 'a2 -> 'a2 **) +let graph_fold f graph0 seed = + let map = graph0 in PositiveMap.fold f map seed + +(** val graph_num_nodes : 'a1 graph -> Nat.nat **) +let graph_num_nodes g = + Identifiers.id_map_size PreIdentifiers.LabelTag g + diff --git a/extracted/graphs.mli b/extracted/graphs.mli new file mode 100644 index 0000000..98e0d04 --- /dev/null +++ b/extracted/graphs.mli @@ -0,0 +1,85 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open BitVectorTrie + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Integers + +open AST + +type label = PreIdentifiers.identifier + +val label_to_ident : label -> AST.ident + +val label_eq : label -> label -> (__, __) Types.sum + +type 'x graph = 'x Identifiers.identifier_map + +val graph_fold : + (Positive.pos -> 'a1 -> 'a2 -> 'a2) -> 'a1 graph -> 'a2 -> 'a2 + +val graph_num_nodes : 'a1 graph -> Nat.nat + diff --git a/extracted/hide.ml b/extracted/hide.ml new file mode 100644 index 0000000..f077cee --- /dev/null +++ b/extracted/hide.ml @@ -0,0 +1,10 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + diff --git a/extracted/hide.mli b/extracted/hide.mli new file mode 100644 index 0000000..f077cee --- /dev/null +++ b/extracted/hide.mli @@ -0,0 +1,10 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + diff --git a/extracted/hints_declaration.ml b/extracted/hints_declaration.ml new file mode 100644 index 0000000..f6bad3b --- /dev/null +++ b/extracted/hints_declaration.ml @@ -0,0 +1,12 @@ +open Preamble + +open Core_notation + +open Pts + +type 'a hint_declaration_Type0 = __ + +type 'a hint_declaration_Type1 = __ + +type ('a, 'b) hint_declaration_Type2 = __ + diff --git a/extracted/hints_declaration.mli b/extracted/hints_declaration.mli new file mode 100644 index 0000000..f6bad3b --- /dev/null +++ b/extracted/hints_declaration.mli @@ -0,0 +1,12 @@ +open Preamble + +open Core_notation + +open Pts + +type 'a hint_declaration_Type0 = __ + +type 'a hint_declaration_Type1 = __ + +type ('a, 'b) hint_declaration_Type2 = __ + diff --git a/extracted/i8051.ml b/extracted/i8051.ml new file mode 100644 index 0000000..fd0939d --- /dev/null +++ b/extracted/i8051.ml @@ -0,0 +1,777 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Jmeq + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open BitVector + +open Arithmetic + +(** val int_size : BitVector.bitVector **) +let int_size = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O) + +(** val ptr_size : BitVector.bitVector **) +let ptr_size = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S Nat.O)) + +(** val alignment : 'a1 Types.option **) +let alignment = + Types.None + +type register = +| Register00 +| Register01 +| Register02 +| Register03 +| Register04 +| Register05 +| Register06 +| Register07 +| Register10 +| Register11 +| Register12 +| Register13 +| Register14 +| Register15 +| Register16 +| Register17 +| Register20 +| Register21 +| Register22 +| Register23 +| Register24 +| Register25 +| Register26 +| Register27 +| Register30 +| Register31 +| Register32 +| Register33 +| Register34 +| Register35 +| Register36 +| Register37 +| RegisterA +| RegisterB +| RegisterDPL +| RegisterDPH +| RegisterCarry + +(** val register_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 **) +let rec register_rect_Type4 h_Register00 h_Register01 h_Register02 h_Register03 h_Register04 h_Register05 h_Register06 h_Register07 h_Register10 h_Register11 h_Register12 h_Register13 h_Register14 h_Register15 h_Register16 h_Register17 h_Register20 h_Register21 h_Register22 h_Register23 h_Register24 h_Register25 h_Register26 h_Register27 h_Register30 h_Register31 h_Register32 h_Register33 h_Register34 h_Register35 h_Register36 h_Register37 h_RegisterA h_RegisterB h_RegisterDPL h_RegisterDPH h_RegisterCarry = function +| Register00 -> h_Register00 +| Register01 -> h_Register01 +| Register02 -> h_Register02 +| Register03 -> h_Register03 +| Register04 -> h_Register04 +| Register05 -> h_Register05 +| Register06 -> h_Register06 +| Register07 -> h_Register07 +| Register10 -> h_Register10 +| Register11 -> h_Register11 +| Register12 -> h_Register12 +| Register13 -> h_Register13 +| Register14 -> h_Register14 +| Register15 -> h_Register15 +| Register16 -> h_Register16 +| Register17 -> h_Register17 +| Register20 -> h_Register20 +| Register21 -> h_Register21 +| Register22 -> h_Register22 +| Register23 -> h_Register23 +| Register24 -> h_Register24 +| Register25 -> h_Register25 +| Register26 -> h_Register26 +| Register27 -> h_Register27 +| Register30 -> h_Register30 +| Register31 -> h_Register31 +| Register32 -> h_Register32 +| Register33 -> h_Register33 +| Register34 -> h_Register34 +| Register35 -> h_Register35 +| Register36 -> h_Register36 +| Register37 -> h_Register37 +| RegisterA -> h_RegisterA +| RegisterB -> h_RegisterB +| RegisterDPL -> h_RegisterDPL +| RegisterDPH -> h_RegisterDPH +| RegisterCarry -> h_RegisterCarry + +(** val register_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 **) +let rec register_rect_Type5 h_Register00 h_Register01 h_Register02 h_Register03 h_Register04 h_Register05 h_Register06 h_Register07 h_Register10 h_Register11 h_Register12 h_Register13 h_Register14 h_Register15 h_Register16 h_Register17 h_Register20 h_Register21 h_Register22 h_Register23 h_Register24 h_Register25 h_Register26 h_Register27 h_Register30 h_Register31 h_Register32 h_Register33 h_Register34 h_Register35 h_Register36 h_Register37 h_RegisterA h_RegisterB h_RegisterDPL h_RegisterDPH h_RegisterCarry = function +| Register00 -> h_Register00 +| Register01 -> h_Register01 +| Register02 -> h_Register02 +| Register03 -> h_Register03 +| Register04 -> h_Register04 +| Register05 -> h_Register05 +| Register06 -> h_Register06 +| Register07 -> h_Register07 +| Register10 -> h_Register10 +| Register11 -> h_Register11 +| Register12 -> h_Register12 +| Register13 -> h_Register13 +| Register14 -> h_Register14 +| Register15 -> h_Register15 +| Register16 -> h_Register16 +| Register17 -> h_Register17 +| Register20 -> h_Register20 +| Register21 -> h_Register21 +| Register22 -> h_Register22 +| Register23 -> h_Register23 +| Register24 -> h_Register24 +| Register25 -> h_Register25 +| Register26 -> h_Register26 +| Register27 -> h_Register27 +| Register30 -> h_Register30 +| Register31 -> h_Register31 +| Register32 -> h_Register32 +| Register33 -> h_Register33 +| Register34 -> h_Register34 +| Register35 -> h_Register35 +| Register36 -> h_Register36 +| Register37 -> h_Register37 +| RegisterA -> h_RegisterA +| RegisterB -> h_RegisterB +| RegisterDPL -> h_RegisterDPL +| RegisterDPH -> h_RegisterDPH +| RegisterCarry -> h_RegisterCarry + +(** val register_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 **) +let rec register_rect_Type3 h_Register00 h_Register01 h_Register02 h_Register03 h_Register04 h_Register05 h_Register06 h_Register07 h_Register10 h_Register11 h_Register12 h_Register13 h_Register14 h_Register15 h_Register16 h_Register17 h_Register20 h_Register21 h_Register22 h_Register23 h_Register24 h_Register25 h_Register26 h_Register27 h_Register30 h_Register31 h_Register32 h_Register33 h_Register34 h_Register35 h_Register36 h_Register37 h_RegisterA h_RegisterB h_RegisterDPL h_RegisterDPH h_RegisterCarry = function +| Register00 -> h_Register00 +| Register01 -> h_Register01 +| Register02 -> h_Register02 +| Register03 -> h_Register03 +| Register04 -> h_Register04 +| Register05 -> h_Register05 +| Register06 -> h_Register06 +| Register07 -> h_Register07 +| Register10 -> h_Register10 +| Register11 -> h_Register11 +| Register12 -> h_Register12 +| Register13 -> h_Register13 +| Register14 -> h_Register14 +| Register15 -> h_Register15 +| Register16 -> h_Register16 +| Register17 -> h_Register17 +| Register20 -> h_Register20 +| Register21 -> h_Register21 +| Register22 -> h_Register22 +| Register23 -> h_Register23 +| Register24 -> h_Register24 +| Register25 -> h_Register25 +| Register26 -> h_Register26 +| Register27 -> h_Register27 +| Register30 -> h_Register30 +| Register31 -> h_Register31 +| Register32 -> h_Register32 +| Register33 -> h_Register33 +| Register34 -> h_Register34 +| Register35 -> h_Register35 +| Register36 -> h_Register36 +| Register37 -> h_Register37 +| RegisterA -> h_RegisterA +| RegisterB -> h_RegisterB +| RegisterDPL -> h_RegisterDPL +| RegisterDPH -> h_RegisterDPH +| RegisterCarry -> h_RegisterCarry + +(** val register_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 **) +let rec register_rect_Type2 h_Register00 h_Register01 h_Register02 h_Register03 h_Register04 h_Register05 h_Register06 h_Register07 h_Register10 h_Register11 h_Register12 h_Register13 h_Register14 h_Register15 h_Register16 h_Register17 h_Register20 h_Register21 h_Register22 h_Register23 h_Register24 h_Register25 h_Register26 h_Register27 h_Register30 h_Register31 h_Register32 h_Register33 h_Register34 h_Register35 h_Register36 h_Register37 h_RegisterA h_RegisterB h_RegisterDPL h_RegisterDPH h_RegisterCarry = function +| Register00 -> h_Register00 +| Register01 -> h_Register01 +| Register02 -> h_Register02 +| Register03 -> h_Register03 +| Register04 -> h_Register04 +| Register05 -> h_Register05 +| Register06 -> h_Register06 +| Register07 -> h_Register07 +| Register10 -> h_Register10 +| Register11 -> h_Register11 +| Register12 -> h_Register12 +| Register13 -> h_Register13 +| Register14 -> h_Register14 +| Register15 -> h_Register15 +| Register16 -> h_Register16 +| Register17 -> h_Register17 +| Register20 -> h_Register20 +| Register21 -> h_Register21 +| Register22 -> h_Register22 +| Register23 -> h_Register23 +| Register24 -> h_Register24 +| Register25 -> h_Register25 +| Register26 -> h_Register26 +| Register27 -> h_Register27 +| Register30 -> h_Register30 +| Register31 -> h_Register31 +| Register32 -> h_Register32 +| Register33 -> h_Register33 +| Register34 -> h_Register34 +| Register35 -> h_Register35 +| Register36 -> h_Register36 +| Register37 -> h_Register37 +| RegisterA -> h_RegisterA +| RegisterB -> h_RegisterB +| RegisterDPL -> h_RegisterDPL +| RegisterDPH -> h_RegisterDPH +| RegisterCarry -> h_RegisterCarry + +(** val register_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 **) +let rec register_rect_Type1 h_Register00 h_Register01 h_Register02 h_Register03 h_Register04 h_Register05 h_Register06 h_Register07 h_Register10 h_Register11 h_Register12 h_Register13 h_Register14 h_Register15 h_Register16 h_Register17 h_Register20 h_Register21 h_Register22 h_Register23 h_Register24 h_Register25 h_Register26 h_Register27 h_Register30 h_Register31 h_Register32 h_Register33 h_Register34 h_Register35 h_Register36 h_Register37 h_RegisterA h_RegisterB h_RegisterDPL h_RegisterDPH h_RegisterCarry = function +| Register00 -> h_Register00 +| Register01 -> h_Register01 +| Register02 -> h_Register02 +| Register03 -> h_Register03 +| Register04 -> h_Register04 +| Register05 -> h_Register05 +| Register06 -> h_Register06 +| Register07 -> h_Register07 +| Register10 -> h_Register10 +| Register11 -> h_Register11 +| Register12 -> h_Register12 +| Register13 -> h_Register13 +| Register14 -> h_Register14 +| Register15 -> h_Register15 +| Register16 -> h_Register16 +| Register17 -> h_Register17 +| Register20 -> h_Register20 +| Register21 -> h_Register21 +| Register22 -> h_Register22 +| Register23 -> h_Register23 +| Register24 -> h_Register24 +| Register25 -> h_Register25 +| Register26 -> h_Register26 +| Register27 -> h_Register27 +| Register30 -> h_Register30 +| Register31 -> h_Register31 +| Register32 -> h_Register32 +| Register33 -> h_Register33 +| Register34 -> h_Register34 +| Register35 -> h_Register35 +| Register36 -> h_Register36 +| Register37 -> h_Register37 +| RegisterA -> h_RegisterA +| RegisterB -> h_RegisterB +| RegisterDPL -> h_RegisterDPL +| RegisterDPH -> h_RegisterDPH +| RegisterCarry -> h_RegisterCarry + +(** val register_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 **) +let rec register_rect_Type0 h_Register00 h_Register01 h_Register02 h_Register03 h_Register04 h_Register05 h_Register06 h_Register07 h_Register10 h_Register11 h_Register12 h_Register13 h_Register14 h_Register15 h_Register16 h_Register17 h_Register20 h_Register21 h_Register22 h_Register23 h_Register24 h_Register25 h_Register26 h_Register27 h_Register30 h_Register31 h_Register32 h_Register33 h_Register34 h_Register35 h_Register36 h_Register37 h_RegisterA h_RegisterB h_RegisterDPL h_RegisterDPH h_RegisterCarry = function +| Register00 -> h_Register00 +| Register01 -> h_Register01 +| Register02 -> h_Register02 +| Register03 -> h_Register03 +| Register04 -> h_Register04 +| Register05 -> h_Register05 +| Register06 -> h_Register06 +| Register07 -> h_Register07 +| Register10 -> h_Register10 +| Register11 -> h_Register11 +| Register12 -> h_Register12 +| Register13 -> h_Register13 +| Register14 -> h_Register14 +| Register15 -> h_Register15 +| Register16 -> h_Register16 +| Register17 -> h_Register17 +| Register20 -> h_Register20 +| Register21 -> h_Register21 +| Register22 -> h_Register22 +| Register23 -> h_Register23 +| Register24 -> h_Register24 +| Register25 -> h_Register25 +| Register26 -> h_Register26 +| Register27 -> h_Register27 +| Register30 -> h_Register30 +| Register31 -> h_Register31 +| Register32 -> h_Register32 +| Register33 -> h_Register33 +| Register34 -> h_Register34 +| Register35 -> h_Register35 +| Register36 -> h_Register36 +| Register37 -> h_Register37 +| RegisterA -> h_RegisterA +| RegisterB -> h_RegisterB +| RegisterDPL -> h_RegisterDPL +| RegisterDPH -> h_RegisterDPH +| RegisterCarry -> h_RegisterCarry + +(** val register_inv_rect_Type4 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let register_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 = + let hcut = + register_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 + h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 + h34 h35 h36 h37 hterm + in + hcut __ + +(** val register_inv_rect_Type3 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let register_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 = + let hcut = + register_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 + h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 + h34 h35 h36 h37 hterm + in + hcut __ + +(** val register_inv_rect_Type2 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let register_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 = + let hcut = + register_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 + h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 + h34 h35 h36 h37 hterm + in + hcut __ + +(** val register_inv_rect_Type1 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let register_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 = + let hcut = + register_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 + h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 + h34 h35 h36 h37 hterm + in + hcut __ + +(** val register_inv_rect_Type0 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let register_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 h34 h35 h36 h37 = + let hcut = + register_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 + h16 h17 h18 h19 h20 h21 h22 h23 h24 h25 h26 h27 h28 h29 h30 h31 h32 h33 + h34 h35 h36 h37 hterm + in + hcut __ + +(** val register_discr : register -> register -> __ **) +let register_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Register00 -> Obj.magic (fun _ dH -> dH) + | Register01 -> Obj.magic (fun _ dH -> dH) + | Register02 -> Obj.magic (fun _ dH -> dH) + | Register03 -> Obj.magic (fun _ dH -> dH) + | Register04 -> Obj.magic (fun _ dH -> dH) + | Register05 -> Obj.magic (fun _ dH -> dH) + | Register06 -> Obj.magic (fun _ dH -> dH) + | Register07 -> Obj.magic (fun _ dH -> dH) + | Register10 -> Obj.magic (fun _ dH -> dH) + | Register11 -> Obj.magic (fun _ dH -> dH) + | Register12 -> Obj.magic (fun _ dH -> dH) + | Register13 -> Obj.magic (fun _ dH -> dH) + | Register14 -> Obj.magic (fun _ dH -> dH) + | Register15 -> Obj.magic (fun _ dH -> dH) + | Register16 -> Obj.magic (fun _ dH -> dH) + | Register17 -> Obj.magic (fun _ dH -> dH) + | Register20 -> Obj.magic (fun _ dH -> dH) + | Register21 -> Obj.magic (fun _ dH -> dH) + | Register22 -> Obj.magic (fun _ dH -> dH) + | Register23 -> Obj.magic (fun _ dH -> dH) + | Register24 -> Obj.magic (fun _ dH -> dH) + | Register25 -> Obj.magic (fun _ dH -> dH) + | Register26 -> Obj.magic (fun _ dH -> dH) + | Register27 -> Obj.magic (fun _ dH -> dH) + | Register30 -> Obj.magic (fun _ dH -> dH) + | Register31 -> Obj.magic (fun _ dH -> dH) + | Register32 -> Obj.magic (fun _ dH -> dH) + | Register33 -> Obj.magic (fun _ dH -> dH) + | Register34 -> Obj.magic (fun _ dH -> dH) + | Register35 -> Obj.magic (fun _ dH -> dH) + | Register36 -> Obj.magic (fun _ dH -> dH) + | Register37 -> Obj.magic (fun _ dH -> dH) + | RegisterA -> Obj.magic (fun _ dH -> dH) + | RegisterB -> Obj.magic (fun _ dH -> dH) + | RegisterDPL -> Obj.magic (fun _ dH -> dH) + | RegisterDPH -> Obj.magic (fun _ dH -> dH) + | RegisterCarry -> Obj.magic (fun _ dH -> dH)) y + +(** val register_jmdiscr : register -> register -> __ **) +let register_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Register00 -> Obj.magic (fun _ dH -> dH) + | Register01 -> Obj.magic (fun _ dH -> dH) + | Register02 -> Obj.magic (fun _ dH -> dH) + | Register03 -> Obj.magic (fun _ dH -> dH) + | Register04 -> Obj.magic (fun _ dH -> dH) + | Register05 -> Obj.magic (fun _ dH -> dH) + | Register06 -> Obj.magic (fun _ dH -> dH) + | Register07 -> Obj.magic (fun _ dH -> dH) + | Register10 -> Obj.magic (fun _ dH -> dH) + | Register11 -> Obj.magic (fun _ dH -> dH) + | Register12 -> Obj.magic (fun _ dH -> dH) + | Register13 -> Obj.magic (fun _ dH -> dH) + | Register14 -> Obj.magic (fun _ dH -> dH) + | Register15 -> Obj.magic (fun _ dH -> dH) + | Register16 -> Obj.magic (fun _ dH -> dH) + | Register17 -> Obj.magic (fun _ dH -> dH) + | Register20 -> Obj.magic (fun _ dH -> dH) + | Register21 -> Obj.magic (fun _ dH -> dH) + | Register22 -> Obj.magic (fun _ dH -> dH) + | Register23 -> Obj.magic (fun _ dH -> dH) + | Register24 -> Obj.magic (fun _ dH -> dH) + | Register25 -> Obj.magic (fun _ dH -> dH) + | Register26 -> Obj.magic (fun _ dH -> dH) + | Register27 -> Obj.magic (fun _ dH -> dH) + | Register30 -> Obj.magic (fun _ dH -> dH) + | Register31 -> Obj.magic (fun _ dH -> dH) + | Register32 -> Obj.magic (fun _ dH -> dH) + | Register33 -> Obj.magic (fun _ dH -> dH) + | Register34 -> Obj.magic (fun _ dH -> dH) + | Register35 -> Obj.magic (fun _ dH -> dH) + | Register36 -> Obj.magic (fun _ dH -> dH) + | Register37 -> Obj.magic (fun _ dH -> dH) + | RegisterA -> Obj.magic (fun _ dH -> dH) + | RegisterB -> Obj.magic (fun _ dH -> dH) + | RegisterDPL -> Obj.magic (fun _ dH -> dH) + | RegisterDPH -> Obj.magic (fun _ dH -> dH) + | RegisterCarry -> Obj.magic (fun _ dH -> dH)) y + +(** val nat_of_register : register -> Nat.nat **) +let nat_of_register = function +| Register00 -> Nat.O +| Register01 -> Nat.S Nat.O +| Register02 -> Nat.S (Nat.S Nat.O) +| Register03 -> Nat.S (Nat.S (Nat.S Nat.O)) +| Register04 -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O))) +| Register05 -> Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) +| Register06 -> Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) +| Register07 -> Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) +| Register10 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))) +| Register11 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) +| Register12 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) +| Register13 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) +| Register14 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))) +| Register15 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))) +| Register16 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))) +| Register17 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))) +| Register20 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))) +| Register21 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) +| Register22 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))) +| Register23 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))) +| Register24 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))) +| Register25 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))) +| Register26 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))))))) +| Register27 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))))))))) +| Register30 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))))))))) +| Register31 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))))))))))) +| Register32 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))))))))))) +| Register33 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))))))))))))) +| Register34 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))) +| Register35 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))) +| Register36 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))) +| Register37 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))) +| RegisterA -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))))))))))))))))) +| RegisterB -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))))))))))))))))))) +| RegisterDPL -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))))))))))))))))))) +| RegisterDPH -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))))))))))))))))))))) +| RegisterCarry -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))) + +(** val physical_register_count : Nat.nat **) +let physical_register_count = + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))) + +(** val bitvector_of_register : register -> BitVector.bitVector **) +let bitvector_of_register register0 = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (nat_of_register register0) + +(** val eq_Register : register -> register -> Bool.bool **) +let eq_Register r s = + let r_as_nat = nat_of_register r in + let s_as_nat = nat_of_register s in Nat.eqb r_as_nat s_as_nat + +(** val registerSST : register **) +let registerSST = + Register10 + +(** val registerST0 : register **) +let registerST0 = + Register02 + +(** val registerST1 : register **) +let registerST1 = + Register03 + +(** val registerST2 : register **) +let registerST2 = + Register04 + +(** val registerST3 : register **) +let registerST3 = + Register05 + +(** val registerSTS : register List.list **) +let registerSTS = + List.Cons (registerST0, (List.Cons (registerST1, (List.Cons (registerST2, + (List.Cons (registerST3, List.Nil))))))) + +(** val registerSPL : register **) +let registerSPL = + Register06 + +(** val registerSPH : register **) +let registerSPH = + Register07 + +(** val registerParams : register List.list **) +let registerParams = + List.Cons (Register30, (List.Cons (Register31, (List.Cons (Register32, + (List.Cons (Register33, (List.Cons (Register34, (List.Cons (Register35, + (List.Cons (Register36, (List.Cons (Register37, List.Nil))))))))))))))) + +(** val registers : register List.list **) +let registers = + List.Cons (Register00, (List.Cons (Register01, (List.Cons (Register02, + (List.Cons (Register03, (List.Cons (Register04, (List.Cons (Register05, + (List.Cons (Register06, (List.Cons (Register07, (List.Cons (Register10, + (List.Cons (Register11, (List.Cons (Register12, (List.Cons (Register13, + (List.Cons (Register14, (List.Cons (Register15, (List.Cons (Register16, + (List.Cons (Register17, (List.Cons (Register20, (List.Cons (Register21, + (List.Cons (Register22, (List.Cons (Register23, (List.Cons (Register24, + (List.Cons (Register25, (List.Cons (Register26, (List.Cons (Register27, + (List.Cons (Register30, (List.Cons (Register31, (List.Cons (Register32, + (List.Cons (Register33, (List.Cons (Register34, (List.Cons (Register35, + (List.Cons (Register36, (List.Cons (Register37, (List.Cons (RegisterA, + (List.Cons (RegisterB, (List.Cons (RegisterDPL, (List.Cons (RegisterDPH, + (List.Cons (registerSPL, (List.Cons (registerSPH, (List.Cons + (registerST0, (List.Cons (registerST1, (List.Cons (registerSST, + List.Nil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + +(** val registerRets : register List.list **) +let registerRets = + List.Cons (RegisterDPL, (List.Cons (RegisterDPH, (List.Cons (Register00, + (List.Cons (Register01, List.Nil))))))) + +(** val registerCallerSaved : register List.list **) +let registerCallerSaved = + List.Cons (Register00, (List.Cons (Register01, (List.Cons (Register02, + (List.Cons (Register03, (List.Cons (Register04, (List.Cons (Register05, + (List.Cons (Register06, (List.Cons (Register07, (List.Cons (Register10, + (List.Cons (Register11, (List.Cons (Register12, (List.Cons (Register13, + (List.Cons (Register14, (List.Cons (Register15, (List.Cons (Register16, + (List.Cons (Register17, (List.Cons (Register30, (List.Cons (Register31, + (List.Cons (Register32, (List.Cons (Register33, (List.Cons (Register34, + (List.Cons (Register35, (List.Cons (Register36, (List.Cons (Register37, + List.Nil))))))))))))))))))))))))))))))))))))))))))))))) + +(** val registerCalleeSaved : register List.list **) +let registerCalleeSaved = + List.Cons (Register20, (List.Cons (Register21, (List.Cons (Register22, + (List.Cons (Register23, (List.Cons (Register24, (List.Cons (Register25, + (List.Cons (Register26, (List.Cons (Register27, List.Nil))))))))))))))) + +(** val registersForbidden : register List.list **) +let registersForbidden = + List.Cons (RegisterA, (List.Cons (RegisterB, (List.Cons (RegisterDPL, + (List.Cons (RegisterDPH, (List.Cons (registerSPL, (List.Cons + (registerSPH, (List.Cons (registerST0, (List.Cons (registerST1, + (List.Cons (registerST2, (List.Cons (registerST3, (List.Cons + (registerSST, List.Nil))))))))))))))))))))) + +(** val registersAllocatable : register List.list **) +let registersAllocatable = + List.Cons (Register00, (List.Cons (Register01, (List.Cons (Register02, + (List.Cons (Register03, (List.Cons (Register04, (List.Cons (Register05, + (List.Cons (Register06, (List.Cons (Register07, (List.Cons (Register10, + (List.Cons (Register11, (List.Cons (Register12, (List.Cons (Register13, + (List.Cons (Register14, (List.Cons (Register15, (List.Cons (Register16, + (List.Cons (Register17, (List.Cons (Register20, (List.Cons (Register21, + (List.Cons (Register22, (List.Cons (Register23, (List.Cons (Register24, + (List.Cons (Register25, (List.Cons (Register26, (List.Cons (Register27, + (List.Cons (Register30, (List.Cons (Register31, (List.Cons (Register32, + (List.Cons (Register33, (List.Cons (Register34, (List.Cons (Register35, + (List.Cons (Register36, (List.Cons (Register37, + List.Nil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + diff --git a/extracted/i8051.mli b/extracted/i8051.mli new file mode 100644 index 0000000..93a5e9f --- /dev/null +++ b/extracted/i8051.mli @@ -0,0 +1,219 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Jmeq + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open BitVector + +open Arithmetic + +val int_size : BitVector.bitVector + +val ptr_size : BitVector.bitVector + +val alignment : 'a1 Types.option + +type register = +| Register00 +| Register01 +| Register02 +| Register03 +| Register04 +| Register05 +| Register06 +| Register07 +| Register10 +| Register11 +| Register12 +| Register13 +| Register14 +| Register15 +| Register16 +| Register17 +| Register20 +| Register21 +| Register22 +| Register23 +| Register24 +| Register25 +| Register26 +| Register27 +| Register30 +| Register31 +| Register32 +| Register33 +| Register34 +| Register35 +| Register36 +| Register37 +| RegisterA +| RegisterB +| RegisterDPL +| RegisterDPH +| RegisterCarry + +val register_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 + +val register_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 + +val register_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 + +val register_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 + +val register_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 + +val register_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> register -> 'a1 + +val register_inv_rect_Type4 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val register_inv_rect_Type3 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val register_inv_rect_Type2 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val register_inv_rect_Type1 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val register_inv_rect_Type0 : + register -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val register_discr : register -> register -> __ + +val register_jmdiscr : register -> register -> __ + +val nat_of_register : register -> Nat.nat + +val physical_register_count : Nat.nat + +val bitvector_of_register : register -> BitVector.bitVector + +val eq_Register : register -> register -> Bool.bool + +val registerSST : register + +val registerST0 : register + +val registerST1 : register + +val registerST2 : register + +val registerST3 : register + +val registerSTS : register List.list + +val registerSPL : register + +val registerSPH : register + +val registerParams : register List.list + +val registers : register List.list + +val registerRets : register List.list + +val registerCallerSaved : register List.list + +val registerCalleeSaved : register List.list + +val registersForbidden : register List.list + +val registersAllocatable : register List.list + diff --git a/extracted/i8051bis.ml b/extracted/i8051bis.ml new file mode 100644 index 0000000..4dfb47c --- /dev/null +++ b/extracted/i8051bis.ml @@ -0,0 +1,35 @@ +open Preamble + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +(** val internal_ram_size : Z.z **) +let internal_ram_size = + Z.two_p + (Z.z_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) + +(** val external_ram_size : Z.z **) +let external_ram_size = + Z.two_p + (Z.z_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) + diff --git a/extracted/i8051bis.mli b/extracted/i8051bis.mli new file mode 100644 index 0000000..b50db7e --- /dev/null +++ b/extracted/i8051bis.mli @@ -0,0 +1,26 @@ +open Preamble + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +val internal_ram_size : Z.z + +val external_ram_size : Z.z + diff --git a/extracted/iO.ml b/extracted/iO.ml new file mode 100644 index 0000000..af97e83 --- /dev/null +++ b/extracted/iO.ml @@ -0,0 +1,269 @@ +open Preamble + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open IOMonad + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +type eventval_type = __ + +(** val mk_eventval : AST.typ -> eventval_type -> Events.eventval **) +let mk_eventval = function +| AST.ASTint (sz, sg) -> (fun v -> Events.EVint (sz, (Obj.magic v))) +| AST.ASTptr -> Obj.magic (fun _ -> assert false (* absurd case *)) + +(** val mk_val : AST.typ -> eventval_type -> Values.val0 **) +let mk_val = function +| AST.ASTint (sz, x) -> (fun v -> Values.Vint (sz, (Obj.magic v))) +| AST.ASTptr -> Obj.magic (fun _ -> assert false (* absurd case *)) + +(** val convert_eventval : + Events.eventval -> AST.typ -> Values.val0 Errors.res **) +let convert_eventval ev = function +| AST.ASTint (sz, x) -> + let Events.EVint (sz', i) = ev in + (match AST.eq_intsize sz sz' with + | Bool.True -> Errors.OK (Values.Vint (sz', i)) + | Bool.False -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent)) +| AST.ASTptr -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent) + +(** val check_eventval' : + Values.val0 -> AST.typ -> Events.eventval Errors.res **) +let check_eventval' v = function +| AST.ASTint (sz, x) -> + (match v with + | Values.Vundef -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent) + | Values.Vint (sz', i) -> + (match AST.eq_intsize sz sz' with + | Bool.True -> Errors.OK (Events.EVint (sz', i)) + | Bool.False -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent)) + | Values.Vnull -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent) + | Values.Vptr x0 -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent)) +| AST.ASTptr -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent) + +(** val check_eventval_list : + Values.val0 List.list -> AST.typ List.list -> Events.eventval List.list + Errors.res **) +let rec check_eventval_list vs tys = + match vs with + | List.Nil -> + (match tys with + | List.Nil -> Errors.OK List.Nil + | List.Cons (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.IllTypedEvent)) + | List.Cons (v, vt) -> + (match tys with + | List.Nil -> Errors.Error (Errors.msg ErrorMessages.IllTypedEvent) + | List.Cons (ty, tyt) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (check_eventval' v ty)) (fun ev -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (check_eventval_list vt tyt)) (fun evt -> + Obj.magic (Errors.OK (List.Cons (ev, evt))))))) + +type io_out = { io_function : AST.ident; io_args : Events.eventval List.list; + io_in_typ : AST.typ } + +(** val io_out_rect_Type4 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> + 'a1 **) +let rec io_out_rect_Type4 h_mk_io_out x_5899 = + let { io_function = io_function0; io_args = io_args0; io_in_typ = + io_in_typ0 } = x_5899 + in + h_mk_io_out io_function0 io_args0 io_in_typ0 + +(** val io_out_rect_Type5 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> + 'a1 **) +let rec io_out_rect_Type5 h_mk_io_out x_5901 = + let { io_function = io_function0; io_args = io_args0; io_in_typ = + io_in_typ0 } = x_5901 + in + h_mk_io_out io_function0 io_args0 io_in_typ0 + +(** val io_out_rect_Type3 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> + 'a1 **) +let rec io_out_rect_Type3 h_mk_io_out x_5903 = + let { io_function = io_function0; io_args = io_args0; io_in_typ = + io_in_typ0 } = x_5903 + in + h_mk_io_out io_function0 io_args0 io_in_typ0 + +(** val io_out_rect_Type2 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> + 'a1 **) +let rec io_out_rect_Type2 h_mk_io_out x_5905 = + let { io_function = io_function0; io_args = io_args0; io_in_typ = + io_in_typ0 } = x_5905 + in + h_mk_io_out io_function0 io_args0 io_in_typ0 + +(** val io_out_rect_Type1 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> + 'a1 **) +let rec io_out_rect_Type1 h_mk_io_out x_5907 = + let { io_function = io_function0; io_args = io_args0; io_in_typ = + io_in_typ0 } = x_5907 + in + h_mk_io_out io_function0 io_args0 io_in_typ0 + +(** val io_out_rect_Type0 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> + 'a1 **) +let rec io_out_rect_Type0 h_mk_io_out x_5909 = + let { io_function = io_function0; io_args = io_args0; io_in_typ = + io_in_typ0 } = x_5909 + in + h_mk_io_out io_function0 io_args0 io_in_typ0 + +(** val io_function : io_out -> AST.ident **) +let rec io_function xxx = + xxx.io_function + +(** val io_args : io_out -> Events.eventval List.list **) +let rec io_args xxx = + xxx.io_args + +(** val io_in_typ : io_out -> AST.typ **) +let rec io_in_typ xxx = + xxx.io_in_typ + +(** val io_out_inv_rect_Type4 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> + 'a1) -> 'a1 **) +let io_out_inv_rect_Type4 hterm h1 = + let hcut = io_out_rect_Type4 h1 hterm in hcut __ + +(** val io_out_inv_rect_Type3 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> + 'a1) -> 'a1 **) +let io_out_inv_rect_Type3 hterm h1 = + let hcut = io_out_rect_Type3 h1 hterm in hcut __ + +(** val io_out_inv_rect_Type2 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> + 'a1) -> 'a1 **) +let io_out_inv_rect_Type2 hterm h1 = + let hcut = io_out_rect_Type2 h1 hterm in hcut __ + +(** val io_out_inv_rect_Type1 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> + 'a1) -> 'a1 **) +let io_out_inv_rect_Type1 hterm h1 = + let hcut = io_out_rect_Type1 h1 hterm in hcut __ + +(** val io_out_inv_rect_Type0 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> + 'a1) -> 'a1 **) +let io_out_inv_rect_Type0 hterm h1 = + let hcut = io_out_rect_Type0 h1 hterm in hcut __ + +(** val io_out_discr : io_out -> io_out -> __ **) +let io_out_discr x y = + Logic.eq_rect_Type2 x + (let { io_function = a0; io_args = a1; io_in_typ = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val io_out_jmdiscr : io_out -> io_out -> __ **) +let io_out_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { io_function = a0; io_args = a1; io_in_typ = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +type io_in = eventval_type + +(** val do_io : + AST.ident -> Events.eventval List.list -> AST.typ -> (io_out, io_in, + eventval_type) IOMonad.iO **) +let do_io fn args t = + IOMonad.Interact ({ io_function = fn; io_args = args; io_in_typ = t }, + (fun res -> IOMonad.Value res)) + +(** val ret : 'a1 -> (io_out, io_in, 'a1) IOMonad.iO **) +let ret x = + IOMonad.Value x + diff --git a/extracted/iO.mli b/extracted/iO.mli new file mode 100644 index 0000000..8742e37 --- /dev/null +++ b/extracted/iO.mli @@ -0,0 +1,161 @@ +open Preamble + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open IOMonad + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +type eventval_type = __ + +val mk_eventval : AST.typ -> eventval_type -> Events.eventval + +val mk_val : AST.typ -> eventval_type -> Values.val0 + +val convert_eventval : Events.eventval -> AST.typ -> Values.val0 Errors.res + +val check_eventval' : Values.val0 -> AST.typ -> Events.eventval Errors.res + +val check_eventval_list : + Values.val0 List.list -> AST.typ List.list -> Events.eventval List.list + Errors.res + +type io_out = { io_function : AST.ident; io_args : Events.eventval List.list; + io_in_typ : AST.typ } + +val io_out_rect_Type4 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> 'a1 + +val io_out_rect_Type5 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> 'a1 + +val io_out_rect_Type3 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> 'a1 + +val io_out_rect_Type2 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> 'a1 + +val io_out_rect_Type1 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> 'a1 + +val io_out_rect_Type0 : + (AST.ident -> Events.eventval List.list -> AST.typ -> 'a1) -> io_out -> 'a1 + +val io_function : io_out -> AST.ident + +val io_args : io_out -> Events.eventval List.list + +val io_in_typ : io_out -> AST.typ + +val io_out_inv_rect_Type4 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> 'a1) + -> 'a1 + +val io_out_inv_rect_Type3 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> 'a1) + -> 'a1 + +val io_out_inv_rect_Type2 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> 'a1) + -> 'a1 + +val io_out_inv_rect_Type1 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> 'a1) + -> 'a1 + +val io_out_inv_rect_Type0 : + io_out -> (AST.ident -> Events.eventval List.list -> AST.typ -> __ -> 'a1) + -> 'a1 + +val io_out_discr : io_out -> io_out -> __ + +val io_out_jmdiscr : io_out -> io_out -> __ + +type io_in = eventval_type + +val do_io : + AST.ident -> Events.eventval List.list -> AST.typ -> (io_out, io_in, + eventval_type) IOMonad.iO + +val ret : 'a1 -> (io_out, io_in, 'a1) IOMonad.iO + diff --git a/extracted/iOMonad.ml b/extracted/iOMonad.ml new file mode 100644 index 0000000..92878ae --- /dev/null +++ b/extracted/iOMonad.ml @@ -0,0 +1,556 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +type ('output, 'input, 't) iO = +| Interact of 'output * ('input -> ('output, 'input, 't) iO) +| Value of 't +| Wrong of Errors.errmsg + +(** val iO_rect_Type4 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> + 'a4) -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 **) +let rec iO_rect_Type4 h_Interact h_Value h_Wrong = function +| Interact (o, x_4685) -> + h_Interact o x_4685 (fun x_4684 -> + iO_rect_Type4 h_Interact h_Value h_Wrong (x_4685 x_4684)) +| Value x_4686 -> h_Value x_4686 +| Wrong x_4687 -> h_Wrong x_4687 + +(** val iO_rect_Type3 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> + 'a4) -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 **) +let rec iO_rect_Type3 h_Interact h_Value h_Wrong = function +| Interact (o, x_4701) -> + h_Interact o x_4701 (fun x_4700 -> + iO_rect_Type3 h_Interact h_Value h_Wrong (x_4701 x_4700)) +| Value x_4702 -> h_Value x_4702 +| Wrong x_4703 -> h_Wrong x_4703 + +(** val iO_rect_Type2 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> + 'a4) -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 **) +let rec iO_rect_Type2 h_Interact h_Value h_Wrong = function +| Interact (o, x_4709) -> + h_Interact o x_4709 (fun x_4708 -> + iO_rect_Type2 h_Interact h_Value h_Wrong (x_4709 x_4708)) +| Value x_4710 -> h_Value x_4710 +| Wrong x_4711 -> h_Wrong x_4711 + +(** val iO_rect_Type1 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> + 'a4) -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 **) +let rec iO_rect_Type1 h_Interact h_Value h_Wrong = function +| Interact (o, x_4717) -> + h_Interact o x_4717 (fun x_4716 -> + iO_rect_Type1 h_Interact h_Value h_Wrong (x_4717 x_4716)) +| Value x_4718 -> h_Value x_4718 +| Wrong x_4719 -> h_Wrong x_4719 + +(** val iO_rect_Type0 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> + 'a4) -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 **) +let rec iO_rect_Type0 h_Interact h_Value h_Wrong = function +| Interact (o, x_4725) -> + h_Interact o x_4725 (fun x_4724 -> + iO_rect_Type0 h_Interact h_Value h_Wrong (x_4725 x_4724)) +| Value x_4726 -> h_Value x_4726 +| Wrong x_4727 -> h_Wrong x_4727 + +(** val iO_inv_rect_Type4 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ + -> 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> + 'a4) -> 'a4 **) +let iO_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = iO_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val iO_inv_rect_Type3 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ + -> 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> + 'a4) -> 'a4 **) +let iO_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = iO_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val iO_inv_rect_Type2 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ + -> 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> + 'a4) -> 'a4 **) +let iO_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = iO_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val iO_inv_rect_Type1 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ + -> 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> + 'a4) -> 'a4 **) +let iO_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = iO_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val iO_inv_rect_Type0 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ + -> 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> + 'a4) -> 'a4 **) +let iO_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = iO_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val iO_discr : ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3) iO -> __ **) +let iO_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Interact (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Value a0 -> Obj.magic (fun _ dH -> dH __) + | Wrong a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val iO_jmdiscr : ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3) iO -> __ **) +let iO_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Interact (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Value a0 -> Obj.magic (fun _ dH -> dH __) + | Wrong a0 -> Obj.magic (fun _ dH -> dH __)) y + +open Proper + +(** val bindIO : + ('a1, 'a2, 'a3) iO -> ('a3 -> ('a1, 'a2, 'a4) iO) -> ('a1, 'a2, 'a4) iO **) +let rec bindIO v f = + match v with + | Interact (out, k) -> Interact (out, (fun res -> bindIO (k res) f)) + | Value v' -> f v' + | Wrong m -> Wrong m + +(** val iOMonad : Monad.monadProps **) +let iOMonad = + Monad.makeMonadProps (fun _ x -> Value x) (fun _ _ -> bindIO) + +(** val bindIO2 : __ -> ('a3 -> 'a4 -> __) -> __ **) +let bindIO2 m f = + Monad.m_bind2 (Monad.max_def iOMonad) m f + +(** val iORel : Monad.monadRel **) +let iORel = + Monad.Mk_MonadRel + +(** val pred_io_inject : + ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3 Types.sig0) iO **) +let rec pred_io_inject a = + (match a with + | Interact (o, f) -> + (fun _ -> Interact (o, (fun x -> pred_io_inject (f x)))) + | Value x -> + (fun _ -> Obj.magic (Monad.m_return0 (Monad.max_def iOMonad) x)) + | Wrong e -> (fun _ -> Wrong e)) __ + +(** val iOPred : Monad.injMonadPred **) +let iOPred = + { Monad.im_pred = Monad.Mk_MonadPred; Monad.mp_inject = (fun _ _ a_sig -> + let a = a_sig in Obj.magic (pred_io_inject (Obj.magic a))) } + +(** val err_to_io : 'a3 Errors.res -> ('a1, 'a2, 'a3) iO **) +let err_to_io = function +| Errors.OK v' -> Value v' +| Errors.Error m -> Wrong m + +(** val dpi1__o__err_to_io__o__inject : + ('a2 Errors.res, 'a3) Types.dPair -> ('a1, 'a4, 'a2) iO Types.sig0 **) +let dpi1__o__err_to_io__o__inject x4 = + err_to_io x4.Types.dpi1 + +(** val eject__o__err_to_io__o__inject : + 'a2 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO Types.sig0 **) +let eject__o__err_to_io__o__inject x4 = + err_to_io (Types.pi1 x4) + +(** val err_to_io__o__inject : + 'a2 Errors.res -> ('a1, 'a3, 'a2) iO Types.sig0 **) +let err_to_io__o__inject x3 = + err_to_io x3 + +(** val dpi1__o__err_to_io : + ('a2 Errors.res, 'a3) Types.dPair -> ('a1, 'a4, 'a2) iO **) +let dpi1__o__err_to_io x4 = + err_to_io x4.Types.dpi1 + +(** val eject__o__err_to_io : + 'a2 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO **) +let eject__o__err_to_io x4 = + err_to_io (Types.pi1 x4) + +(** val err_to_io_sig : + 'a3 Types.sig0 Errors.res -> ('a1, 'a2, 'a3 Types.sig0) iO **) +let err_to_io_sig = function +| Errors.OK v' -> Value v' +| Errors.Error m -> Wrong m + +(** val io_inject_0 : ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3 Types.sig0) iO **) +let rec io_inject_0 a = + (match a with + | Interact (out, k) -> + (fun _ -> Interact (out, (fun v -> io_inject_0 (k v)))) + | Value c -> (fun _ -> Value c) + | Wrong m -> (fun _ -> Wrong m)) __ + +(** val io_inject : + ('a1, 'a2, 'a3) iO Types.option -> ('a1, 'a2, 'a3 Types.sig0) iO **) +let io_inject a = + (match a with + | Types.None -> (fun _ -> Logic.false_rect_Type0 __) + | Types.Some b -> (fun _ -> io_inject_0 b)) __ + +(** val io_eject : ('a1, 'a2, 'a3 Types.sig0) iO -> ('a1, 'a2, 'a3) iO **) +let rec io_eject = function +| Interact (out, k) -> Interact (out, (fun v -> io_eject (k v))) +| Value b -> let w = b in Value w +| Wrong m -> Wrong m + +(** val dpi1__o__io_inject__o__inject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2 + Types.sig0) iO Types.sig0 **) +let dpi1__o__io_inject__o__inject x6 = + io_inject x6.Types.dpi1 + +(** val eject__o__io_inject__o__inject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2 Types.sig0) + iO Types.sig0 **) +let eject__o__io_inject__o__inject x6 = + io_inject (Types.pi1 x6) + +(** val io_inject__o__inject : + ('a1, 'a3, 'a2) iO Types.option -> ('a1, 'a3, 'a2 Types.sig0) iO + Types.sig0 **) +let io_inject__o__inject x5 = + io_inject x5 + +(** val dpi1__o__io_inject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2 + Types.sig0) iO **) +let dpi1__o__io_inject x5 = + io_inject x5.Types.dpi1 + +(** val eject__o__io_inject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2 Types.sig0) + iO **) +let eject__o__io_inject x5 = + io_inject (Types.pi1 x5) + +(** val io_inject__o__io_eject__o__inject : + ('a1, 'a3, 'a2) iO Types.option -> ('a1, 'a3, 'a2) iO Types.sig0 **) +let io_inject__o__io_eject__o__inject x4 = + io_eject (io_inject x4) + +(** val dpi1__o__err_to_io__o__io_eject__o__inject : + ('a2 Types.sig0 Errors.res, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + Types.sig0 **) +let dpi1__o__err_to_io__o__io_eject__o__inject x6 = + io_eject (dpi1__o__err_to_io x6) + +(** val dpi1__o__io_inject__o__io_eject__o__inject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + Types.sig0 **) +let dpi1__o__io_inject__o__io_eject__o__inject x6 = + io_eject (dpi1__o__io_inject x6) + +(** val eject__o__err_to_io__o__io_eject__o__inject : + 'a2 Types.sig0 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO Types.sig0 **) +let eject__o__err_to_io__o__io_eject__o__inject x6 = + io_eject (eject__o__err_to_io x6) + +(** val eject__o__io_inject__o__io_eject__o__inject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2) iO + Types.sig0 **) +let eject__o__io_inject__o__io_eject__o__inject x6 = + io_eject (eject__o__io_inject x6) + +(** val err_to_io__o__io_eject__o__inject : + 'a2 Types.sig0 Errors.res -> ('a1, 'a3, 'a2) iO Types.sig0 **) +let err_to_io__o__io_eject__o__inject x4 = + io_eject (err_to_io x4) + +(** val dpi1__o__io_eject__o__inject : + (('a1, 'a3, 'a2 Types.sig0) iO, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + Types.sig0 **) +let dpi1__o__io_eject__o__inject x6 = + io_eject x6.Types.dpi1 + +(** val eject__o__io_eject__o__inject : + ('a1, 'a3, 'a2 Types.sig0) iO Types.sig0 -> ('a1, 'a3, 'a2) iO Types.sig0 **) +let eject__o__io_eject__o__inject x6 = + io_eject (Types.pi1 x6) + +(** val io_eject__o__inject : + ('a1, 'a3, 'a2 Types.sig0) iO -> ('a1, 'a3, 'a2) iO Types.sig0 **) +let io_eject__o__inject x5 = + io_eject x5 + +(** val io_inject__o__io_eject : + ('a1, 'a3, 'a2) iO Types.option -> ('a1, 'a3, 'a2) iO **) +let io_inject__o__io_eject x4 = + io_eject (io_inject x4) + +(** val dpi1__o__err_to_io__o__io_eject : + ('a2 Types.sig0 Errors.res, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO **) +let dpi1__o__err_to_io__o__io_eject x5 = + io_eject (dpi1__o__err_to_io x5) + +(** val dpi1__o__io_inject__o__io_eject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO **) +let dpi1__o__io_inject__o__io_eject x5 = + io_eject (dpi1__o__io_inject x5) + +(** val eject__o__err_to_io__o__io_eject : + 'a2 Types.sig0 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO **) +let eject__o__err_to_io__o__io_eject x5 = + io_eject (eject__o__err_to_io x5) + +(** val eject__o__io_inject__o__io_eject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2) iO **) +let eject__o__io_inject__o__io_eject x5 = + io_eject (eject__o__io_inject x5) + +(** val err_to_io__o__io_eject : + 'a2 Types.sig0 Errors.res -> ('a1, 'a3, 'a2) iO **) +let err_to_io__o__io_eject x4 = + io_eject (err_to_io x4) + +(** val dpi1__o__io_eject : + (('a1, 'a3, 'a2 Types.sig0) iO, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO **) +let dpi1__o__io_eject x5 = + io_eject x5.Types.dpi1 + +(** val eject__o__io_eject : + ('a1, 'a3, 'a2 Types.sig0) iO Types.sig0 -> ('a1, 'a3, 'a2) iO **) +let eject__o__io_eject x5 = + io_eject (Types.pi1 x5) + +(** val opt_to_io : + Errors.errmsg -> 'a3 Types.option -> ('a1, 'a2, 'a3) iO **) +let opt_to_io m = function +| Types.None -> Wrong m +| Types.Some v' -> Value v' + +(** val bind_res_value : + 'a3 Errors.res -> ('a3 -> 'a4 Errors.res) -> 'a4 -> ('a3 -> __ -> __ -> + 'a5) -> 'a5 **) +let bind_res_value clearme f v x = + (match clearme with + | Errors.OK a -> (fun f0 v0 _ h _ -> h a __ __) + | Errors.Error m -> + (fun f0 v0 _ h _ -> Obj.magic iO_discr (Wrong m) (Value v0) __)) f v __ + x __ + +(** val bindIO_value : + ('a1, 'a2, 'a3) iO -> ('a3 -> ('a1, 'a2, 'a4) iO) -> 'a4 -> ('a3 -> __ -> + __ -> 'a5) -> 'a5 **) +let bindIO_value clearme f v x = + (match clearme with + | Interact (o, k) -> + (fun f0 v0 _ h _ -> + Obj.magic iO_discr (Interact (o, (fun res -> bindIO (k res) f0))) + (Value v0) __) + | Value a -> (fun f0 v0 _ h _ -> h a __ __) + | Wrong m -> + (fun f0 v0 _ h _ -> Obj.magic iO_discr (Wrong m) (Value v0) __)) f v __ + x __ + +(** val bindIO_res_interact : + 'a3 Errors.res -> ('a3 -> ('a1, 'a2, 'a4) iO) -> 'a1 -> ('a2 -> ('a1, + 'a2, 'a4) iO) -> ('a3 -> __ -> __ -> 'a5) -> 'a5 **) +let bindIO_res_interact clearme f o k x = + (match clearme with + | Errors.OK a -> (fun f0 o0 k0 _ h _ -> h a __ __) + | Errors.Error m -> + (fun f0 o0 k0 _ x0 _ -> + Obj.magic iO_discr (Wrong m) (Interact (o0, k0)) __)) f o k __ x __ + +(** val bindIO_opt_interact : + Errors.errmsg -> 'a3 Types.option -> ('a3 -> ('a1, 'a2, 'a4) iO) -> 'a1 + -> ('a2 -> ('a1, 'a2, 'a4) iO) -> ('a3 -> __ -> __ -> 'a5) -> 'a5 **) +let bindIO_opt_interact m clearme f o k x = + (match clearme with + | Types.None -> + (fun f0 o0 k0 _ x0 _ -> + Obj.magic iO_discr (Wrong m) (Interact (o0, k0)) __) + | Types.Some a -> (fun f0 o0 k0 _ h _ -> h a __ __)) f o k __ x __ + +(** val eq_to_rel_io__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 **) +let eq_to_rel_io__o__io_eq_from_res__o__inject x3 x4 = + __ + +(** val eq_to_rel_io__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 **) +let eq_to_rel_io__o__io_eq_from_res__o__opt_eq_from_res__o__inject x2 x4 x5 = + Errors.opt_eq_from_res__o__inject x2 x4 x5 + +(** val jmeq_to_eq__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 **) +let jmeq_to_eq__o__io_eq_from_res__o__inject x3 x4 = + __ + +(** val jmeq_to_eq__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 **) +let jmeq_to_eq__o__io_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val dpi1__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> (__, 'a4) Types.dPair -> __ Types.sig0 **) +let dpi1__o__io_eq_from_res__o__inject x3 x4 x7 = + __ + +(** val dpi1__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> (__, 'a4) Types.dPair -> __ + Types.sig0 **) +let dpi1__o__io_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 x8 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val eject__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 -> __ Types.sig0 **) +let eject__o__io_eq_from_res__o__inject x3 x4 x7 = + __ + +(** val eject__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 -> __ + Types.sig0 **) +let eject__o__io_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 x8 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 **) +let io_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 **) +let io_eq_from_res__o__inject x3 x4 = + __ + +(** val jmeq_to_eq__o__io_monad_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 **) +let jmeq_to_eq__o__io_monad_eq_from_res__o__inject x3 x4 = + __ + +(** val jmeq_to_eq__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 **) +let jmeq_to_eq__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val dpi1__o__io_monad_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> (__, 'a4) Types.dPair -> __ Types.sig0 **) +let dpi1__o__io_monad_eq_from_res__o__inject x3 x4 x7 = + __ + +(** val dpi1__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> (__, 'a4) Types.dPair -> __ + Types.sig0 **) +let dpi1__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 x8 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val eject__o__io_monad_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 -> __ Types.sig0 **) +let eject__o__io_monad_eq_from_res__o__inject x3 x4 x7 = + __ + +(** val eject__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 -> __ + Types.sig0 **) +let eject__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 x8 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 **) +let io_monad_eq_from_res__o__opt_eq_from_res__o__inject x1 x3 x4 = + Errors.opt_eq_from_res__o__inject x1 x3 x4 + +(** val io_monad_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 **) +let io_monad_eq_from_res__o__inject x3 x4 = + __ + +(** val eq_to_rel_io__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 **) +let eq_to_rel_io__o__io_eq_from_opt__o__inject x2 x4 x5 = + __ + +(** val jmeq_to_eq__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 **) +let jmeq_to_eq__o__io_eq_from_opt__o__inject x2 x4 x5 = + __ + +(** val dpi1__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> (__, 'a4) Types.dPair -> __ + Types.sig0 **) +let dpi1__o__io_eq_from_opt__o__inject x2 x4 x5 x8 = + __ + +(** val eject__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 -> __ + Types.sig0 **) +let eject__o__io_eq_from_opt__o__inject x2 x4 x5 x8 = + __ + +(** val io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 **) +let io_eq_from_opt__o__inject x2 x4 x5 = + __ + +(** val jmeq_to_eq__o__io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 **) +let jmeq_to_eq__o__io_monad_eq_from_opt__o__inject x2 x4 x5 = + __ + +(** val dpi1__o__io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> (__, 'a4) Types.dPair -> __ + Types.sig0 **) +let dpi1__o__io_monad_eq_from_opt__o__inject x2 x4 x5 x8 = + __ + +(** val eject__o__io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 -> __ + Types.sig0 **) +let eject__o__io_monad_eq_from_opt__o__inject x2 x4 x5 x8 = + __ + +(** val io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 **) +let io_monad_eq_from_opt__o__inject x2 x4 x5 = + __ + diff --git a/extracted/iOMonad.mli b/extracted/iOMonad.mli new file mode 100644 index 0000000..189a558 --- /dev/null +++ b/extracted/iOMonad.mli @@ -0,0 +1,310 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +type ('output, 'input, 't) iO = +| Interact of 'output * ('input -> ('output, 'input, 't) iO) +| Value of 't +| Wrong of Errors.errmsg + +val iO_rect_Type4 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> 'a4) + -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 + +val iO_rect_Type3 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> 'a4) + -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 + +val iO_rect_Type2 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> 'a4) + -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 + +val iO_rect_Type1 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> 'a4) + -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 + +val iO_rect_Type0 : + ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> 'a4) -> 'a4) -> ('a3 -> 'a4) + -> (Errors.errmsg -> 'a4) -> ('a1, 'a2, 'a3) iO -> 'a4 + +val iO_inv_rect_Type4 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ -> + 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> 'a4) -> + 'a4 + +val iO_inv_rect_Type3 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ -> + 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> 'a4) -> + 'a4 + +val iO_inv_rect_Type2 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ -> + 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> 'a4) -> + 'a4 + +val iO_inv_rect_Type1 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ -> + 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> 'a4) -> + 'a4 + +val iO_inv_rect_Type0 : + ('a1, 'a2, 'a3) iO -> ('a1 -> ('a2 -> ('a1, 'a2, 'a3) iO) -> ('a2 -> __ -> + 'a4) -> __ -> 'a4) -> ('a3 -> __ -> 'a4) -> (Errors.errmsg -> __ -> 'a4) -> + 'a4 + +val iO_discr : ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3) iO -> __ + +val iO_jmdiscr : ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3) iO -> __ + +open Proper + +val bindIO : + ('a1, 'a2, 'a3) iO -> ('a3 -> ('a1, 'a2, 'a4) iO) -> ('a1, 'a2, 'a4) iO + +val iOMonad : Monad.monadProps + +val bindIO2 : __ -> ('a3 -> 'a4 -> __) -> __ + +val iORel : Monad.monadRel + +val pred_io_inject : ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3 Types.sig0) iO + +val iOPred : Monad.injMonadPred + +val err_to_io : 'a3 Errors.res -> ('a1, 'a2, 'a3) iO + +val dpi1__o__err_to_io__o__inject : + ('a2 Errors.res, 'a3) Types.dPair -> ('a1, 'a4, 'a2) iO Types.sig0 + +val eject__o__err_to_io__o__inject : + 'a2 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO Types.sig0 + +val err_to_io__o__inject : 'a2 Errors.res -> ('a1, 'a3, 'a2) iO Types.sig0 + +val dpi1__o__err_to_io : + ('a2 Errors.res, 'a3) Types.dPair -> ('a1, 'a4, 'a2) iO + +val eject__o__err_to_io : 'a2 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO + +val err_to_io_sig : + 'a3 Types.sig0 Errors.res -> ('a1, 'a2, 'a3 Types.sig0) iO + +val io_inject_0 : ('a1, 'a2, 'a3) iO -> ('a1, 'a2, 'a3 Types.sig0) iO + +val io_inject : + ('a1, 'a2, 'a3) iO Types.option -> ('a1, 'a2, 'a3 Types.sig0) iO + +val io_eject : ('a1, 'a2, 'a3 Types.sig0) iO -> ('a1, 'a2, 'a3) iO + +val dpi1__o__io_inject__o__inject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2 + Types.sig0) iO Types.sig0 + +val eject__o__io_inject__o__inject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2 Types.sig0) iO + Types.sig0 + +val io_inject__o__inject : + ('a1, 'a3, 'a2) iO Types.option -> ('a1, 'a3, 'a2 Types.sig0) iO Types.sig0 + +val dpi1__o__io_inject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2 + Types.sig0) iO + +val eject__o__io_inject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2 Types.sig0) iO + +val io_inject__o__io_eject__o__inject : + ('a1, 'a3, 'a2) iO Types.option -> ('a1, 'a3, 'a2) iO Types.sig0 + +val dpi1__o__err_to_io__o__io_eject__o__inject : + ('a2 Types.sig0 Errors.res, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + Types.sig0 + +val dpi1__o__io_inject__o__io_eject__o__inject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + Types.sig0 + +val eject__o__err_to_io__o__io_eject__o__inject : + 'a2 Types.sig0 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO Types.sig0 + +val eject__o__io_inject__o__io_eject__o__inject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2) iO Types.sig0 + +val err_to_io__o__io_eject__o__inject : + 'a2 Types.sig0 Errors.res -> ('a1, 'a3, 'a2) iO Types.sig0 + +val dpi1__o__io_eject__o__inject : + (('a1, 'a3, 'a2 Types.sig0) iO, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + Types.sig0 + +val eject__o__io_eject__o__inject : + ('a1, 'a3, 'a2 Types.sig0) iO Types.sig0 -> ('a1, 'a3, 'a2) iO Types.sig0 + +val io_eject__o__inject : + ('a1, 'a3, 'a2 Types.sig0) iO -> ('a1, 'a3, 'a2) iO Types.sig0 + +val io_inject__o__io_eject : + ('a1, 'a3, 'a2) iO Types.option -> ('a1, 'a3, 'a2) iO + +val dpi1__o__err_to_io__o__io_eject : + ('a2 Types.sig0 Errors.res, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + +val dpi1__o__io_inject__o__io_eject : + (('a1, 'a3, 'a2) iO Types.option, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + +val eject__o__err_to_io__o__io_eject : + 'a2 Types.sig0 Errors.res Types.sig0 -> ('a1, 'a3, 'a2) iO + +val eject__o__io_inject__o__io_eject : + ('a1, 'a3, 'a2) iO Types.option Types.sig0 -> ('a1, 'a3, 'a2) iO + +val err_to_io__o__io_eject : 'a2 Types.sig0 Errors.res -> ('a1, 'a3, 'a2) iO + +val dpi1__o__io_eject : + (('a1, 'a3, 'a2 Types.sig0) iO, 'a4) Types.dPair -> ('a1, 'a3, 'a2) iO + +val eject__o__io_eject : + ('a1, 'a3, 'a2 Types.sig0) iO Types.sig0 -> ('a1, 'a3, 'a2) iO + +val opt_to_io : Errors.errmsg -> 'a3 Types.option -> ('a1, 'a2, 'a3) iO + +val bind_res_value : + 'a3 Errors.res -> ('a3 -> 'a4 Errors.res) -> 'a4 -> ('a3 -> __ -> __ -> + 'a5) -> 'a5 + +val bindIO_value : + ('a1, 'a2, 'a3) iO -> ('a3 -> ('a1, 'a2, 'a4) iO) -> 'a4 -> ('a3 -> __ -> + __ -> 'a5) -> 'a5 + +val bindIO_res_interact : + 'a3 Errors.res -> ('a3 -> ('a1, 'a2, 'a4) iO) -> 'a1 -> ('a2 -> ('a1, 'a2, + 'a4) iO) -> ('a3 -> __ -> __ -> 'a5) -> 'a5 + +val bindIO_opt_interact : + Errors.errmsg -> 'a3 Types.option -> ('a3 -> ('a1, 'a2, 'a4) iO) -> 'a1 -> + ('a2 -> ('a1, 'a2, 'a4) iO) -> ('a3 -> __ -> __ -> 'a5) -> 'a5 + +val eq_to_rel_io__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 + +val eq_to_rel_io__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 + +val jmeq_to_eq__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 + +val jmeq_to_eq__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 + +val dpi1__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> (__, 'a4) Types.dPair -> __ Types.sig0 + +val dpi1__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> (__, 'a4) Types.dPair -> __ + Types.sig0 + +val eject__o__io_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 -> __ Types.sig0 + +val eject__o__io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 -> __ Types.sig0 + +val io_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 + +val io_eq_from_res__o__inject : 'a2 Errors.res -> 'a2 -> __ Types.sig0 + +val jmeq_to_eq__o__io_monad_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 + +val jmeq_to_eq__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 + +val dpi1__o__io_monad_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> (__, 'a4) Types.dPair -> __ Types.sig0 + +val dpi1__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> (__, 'a4) Types.dPair -> __ + Types.sig0 + +val eject__o__io_monad_eq_from_res__o__inject : + 'a2 Errors.res -> 'a2 -> __ Types.sig0 -> __ Types.sig0 + +val eject__o__io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 -> __ Types.sig0 + +val io_monad_eq_from_res__o__opt_eq_from_res__o__inject : + Errors.errmsg -> 'a1 Types.option -> 'a1 -> __ Types.sig0 + +val io_monad_eq_from_res__o__inject : 'a2 Errors.res -> 'a2 -> __ Types.sig0 + +val eq_to_rel_io__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 + +val jmeq_to_eq__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 + +val dpi1__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> (__, 'a4) Types.dPair -> __ + Types.sig0 + +val eject__o__io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 -> __ Types.sig0 + +val io_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 + +val jmeq_to_eq__o__io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 + +val dpi1__o__io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> (__, 'a4) Types.dPair -> __ + Types.sig0 + +val eject__o__io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 -> __ Types.sig0 + +val io_monad_eq_from_opt__o__inject : + Errors.errmsg -> 'a2 Types.option -> 'a2 -> __ Types.sig0 + diff --git a/extracted/identifiers.ml b/extracted/identifiers.ml new file mode 100644 index 0000000..b9bb2cf --- /dev/null +++ b/extracted/identifiers.ml @@ -0,0 +1,525 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Positive + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Extralib + +open ErrorMessages + +open PreIdentifiers + +open Errors + +type universe = + Positive.pos + (* singleton inductive, whose constructor was mk_universe *) + +(** val universe_rect_Type4 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 **) +let rec universe_rect_Type4 tag h_mk_universe x_3239 = + let next_identifier = x_3239 in h_mk_universe next_identifier + +(** val universe_rect_Type5 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 **) +let rec universe_rect_Type5 tag h_mk_universe x_3241 = + let next_identifier = x_3241 in h_mk_universe next_identifier + +(** val universe_rect_Type3 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 **) +let rec universe_rect_Type3 tag h_mk_universe x_3243 = + let next_identifier = x_3243 in h_mk_universe next_identifier + +(** val universe_rect_Type2 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 **) +let rec universe_rect_Type2 tag h_mk_universe x_3245 = + let next_identifier = x_3245 in h_mk_universe next_identifier + +(** val universe_rect_Type1 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 **) +let rec universe_rect_Type1 tag h_mk_universe x_3247 = + let next_identifier = x_3247 in h_mk_universe next_identifier + +(** val universe_rect_Type0 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 **) +let rec universe_rect_Type0 tag h_mk_universe x_3249 = + let next_identifier = x_3249 in h_mk_universe next_identifier + +(** val next_identifier : + PreIdentifiers.identifierTag -> universe -> Positive.pos **) +let rec next_identifier tag xxx = + let yyy = xxx in yyy + +(** val universe_inv_rect_Type4 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) + -> 'a1 **) +let universe_inv_rect_Type4 x1 hterm h1 = + let hcut = universe_rect_Type4 x1 h1 hterm in hcut __ + +(** val universe_inv_rect_Type3 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) + -> 'a1 **) +let universe_inv_rect_Type3 x1 hterm h1 = + let hcut = universe_rect_Type3 x1 h1 hterm in hcut __ + +(** val universe_inv_rect_Type2 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) + -> 'a1 **) +let universe_inv_rect_Type2 x1 hterm h1 = + let hcut = universe_rect_Type2 x1 h1 hterm in hcut __ + +(** val universe_inv_rect_Type1 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) + -> 'a1 **) +let universe_inv_rect_Type1 x1 hterm h1 = + let hcut = universe_rect_Type1 x1 h1 hterm in hcut __ + +(** val universe_inv_rect_Type0 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) + -> 'a1 **) +let universe_inv_rect_Type0 x1 hterm h1 = + let hcut = universe_rect_Type0 x1 h1 hterm in hcut __ + +(** val universe_discr : + PreIdentifiers.identifierTag -> universe -> universe -> __ **) +let universe_discr a1 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val universe_jmdiscr : + PreIdentifiers.identifierTag -> universe -> universe -> __ **) +let universe_jmdiscr a1 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val new_universe : PreIdentifiers.identifierTag -> universe **) +let new_universe tag = + Positive.One + +(** val fresh : + PreIdentifiers.identifierTag -> universe -> (PreIdentifiers.identifier, + universe) Types.prod **) +let rec fresh tag u = + let id = next_identifier tag u in + { Types.fst = id; Types.snd = (Positive.succ id) } + +(** val eq_identifier : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + PreIdentifiers.identifier -> Bool.bool **) +let eq_identifier t l r = + let l' = l in let r' = r in Positive.eqb l' r' + +(** val eq_identifier_elim : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + PreIdentifiers.identifier -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let eq_identifier_elim t clearme = + let x = clearme in + (fun clearme0 -> + let y = clearme0 in + (fun t0 f -> Positive.eqb_elim x y (fun _ -> t0 __) (fun _ -> f __))) + +open Deqsets + +(** val deq_identifier : PreIdentifiers.identifierTag -> Deqsets.deqSet **) +let deq_identifier tag = + Obj.magic (eq_identifier tag) + +(** val word_of_identifier : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> Positive.pos **) +let word_of_identifier t l = + let l' = l in l' + +(** val identifier_eq : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + PreIdentifiers.identifier -> (__, __) Types.sum **) +let identifier_eq tag clearme = + let x = clearme in + (fun clearme0 -> + let y = clearme0 in + (match Positive.eqb x y with + | Bool.True -> (fun _ -> Types.Inl __) + | Bool.False -> (fun _ -> Types.Inr __)) __) + +(** val identifier_of_nat : + PreIdentifiers.identifierTag -> Nat.nat -> PreIdentifiers.identifier **) +let identifier_of_nat tag n = + Positive.succ_pos_of_nat n + +(** val check_member_env : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + (PreIdentifiers.identifier, 'a1) Types.prod List.list -> __ Errors.res **) +let rec check_member_env tag id = function +| List.Nil -> Errors.OK __ +| List.Cons (hd, tl) -> + (match identifier_eq tag id hd.Types.fst with + | Types.Inl _ -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.DuplicateVariable), + (List.Cons ((Errors.CTX (tag, id)), List.Nil)))) + | Types.Inr _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (check_member_env tag id tl)) (fun _ -> + Obj.magic (Errors.OK __)))) + +(** val check_distinct_env : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier, 'a1) + Types.prod List.list -> __ Errors.res **) +let rec check_distinct_env tag = function +| List.Nil -> Errors.OK __ +| List.Cons (hd, tl) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (check_member_env tag hd.Types.fst tl)) (fun _ -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (check_distinct_env tag tl)) (fun _ -> + Obj.magic (Errors.OK __)))) + +open PositiveMap + +type 'a identifier_map = + 'a PositiveMap.positive_map + (* singleton inductive, whose constructor was an_id_map *) + +(** val identifier_map_rect_Type4 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 **) +let rec identifier_map_rect_Type4 tag h_an_id_map x_3411 = + let x_3412 = x_3411 in h_an_id_map x_3412 + +(** val identifier_map_rect_Type5 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 **) +let rec identifier_map_rect_Type5 tag h_an_id_map x_3414 = + let x_3415 = x_3414 in h_an_id_map x_3415 + +(** val identifier_map_rect_Type3 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 **) +let rec identifier_map_rect_Type3 tag h_an_id_map x_3417 = + let x_3418 = x_3417 in h_an_id_map x_3418 + +(** val identifier_map_rect_Type2 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 **) +let rec identifier_map_rect_Type2 tag h_an_id_map x_3420 = + let x_3421 = x_3420 in h_an_id_map x_3421 + +(** val identifier_map_rect_Type1 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 **) +let rec identifier_map_rect_Type1 tag h_an_id_map x_3423 = + let x_3424 = x_3423 in h_an_id_map x_3424 + +(** val identifier_map_rect_Type0 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 **) +let rec identifier_map_rect_Type0 tag h_an_id_map x_3426 = + let x_3427 = x_3426 in h_an_id_map x_3427 + +(** val identifier_map_inv_rect_Type4 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 **) +let identifier_map_inv_rect_Type4 x1 hterm h1 = + let hcut = identifier_map_rect_Type4 x1 h1 hterm in hcut __ + +(** val identifier_map_inv_rect_Type3 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 **) +let identifier_map_inv_rect_Type3 x1 hterm h1 = + let hcut = identifier_map_rect_Type3 x1 h1 hterm in hcut __ + +(** val identifier_map_inv_rect_Type2 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 **) +let identifier_map_inv_rect_Type2 x1 hterm h1 = + let hcut = identifier_map_rect_Type2 x1 h1 hterm in hcut __ + +(** val identifier_map_inv_rect_Type1 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 **) +let identifier_map_inv_rect_Type1 x1 hterm h1 = + let hcut = identifier_map_rect_Type1 x1 h1 hterm in hcut __ + +(** val identifier_map_inv_rect_Type0 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 **) +let identifier_map_inv_rect_Type0 x1 hterm h1 = + let hcut = identifier_map_rect_Type0 x1 h1 hterm in hcut __ + +(** val identifier_map_discr : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a1 identifier_map + -> __ **) +let identifier_map_discr a1 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val identifier_map_jmdiscr : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a1 identifier_map + -> __ **) +let identifier_map_jmdiscr a1 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val empty_map : PreIdentifiers.identifierTag -> 'a1 identifier_map **) +let empty_map tag = + PositiveMap.Pm_leaf + +(** val lookup : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 Types.option **) +let rec lookup tag m l = + PositiveMap.lookup_opt (let l' = l in l') (let m' = m in m') + +(** val lookup_def : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 **) +let lookup_def tag m l d = + match lookup tag m l with + | Types.None -> d + | Types.Some x -> x + +(** val member : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> Bool.bool **) +let member tag m l = + match lookup tag m l with + | Types.None -> Bool.False + | Types.Some x -> Bool.True + +(** val lookup_safe : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 **) +let lookup_safe tag m i = + (match lookup tag m i with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some x -> (fun _ -> x)) __ + +(** val add : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 identifier_map **) +let rec add tag m l a = + PositiveMap.insert (let l' = l in l') a (let m' = m in m') + +(** val elements : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier, 'a1) Types.prod List.list **) +let elements tag m = + PositiveMap.fold (fun l a el -> List.Cons ({ Types.fst = l; Types.snd = + a }, el)) (let m' = m in m') List.Nil + +(** val idmap_all : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier -> 'a1 -> __ -> Bool.bool) -> Bool.bool **) +let idmap_all tag m f = + PositiveMap.pm_all (let m' = m in m') (fun p a _ -> f p a __) + +(** val update : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 identifier_map Errors.res **) +let update tag m l a = + match PositiveMap.update (let l' = l in l') a (let m' = m in m') with + | Types.None -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.MissingId), (List.Cons + ((Errors.CTX (tag, l)), List.Nil)))) + | Types.Some m' -> Errors.OK m' + +(** val remove : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 identifier_map **) +let remove tag m id = + PositiveMap.pm_set (let p = id in p) Types.None (let m0 = m in m0) + +(** val foldi : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier -> 'a1 -> 'a2 + -> 'a2) -> 'a1 identifier_map -> 'a2 -> 'a2 **) +let foldi tag f m b = + let m' = m in PositiveMap.fold (fun bv -> f bv) m' b + +(** val fold_inf : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier -> 'a1 -> __ -> 'a2 -> 'a2) -> 'a2 -> 'a2 **) +let fold_inf tag m = + let m' = m in + (fun f b -> PositiveMap.pm_fold_inf m' (fun bv a _ -> f bv a __) b) + +(** val find : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier -> 'a1 -> Bool.bool) -> + (PreIdentifiers.identifier, 'a1) Types.prod Types.option **) +let find tag m p = + let m' = m in + Types.option_map (fun x -> { Types.fst = x.Types.fst; Types.snd = + x.Types.snd }) (PositiveMap.pm_find m' (fun id -> p id)) + +(** val lookup_present : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 **) +let lookup_present tag m id = + (match lookup tag m id with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some a -> (fun _ -> a)) __ + +(** val update_present : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 identifier_map **) +let update_present tag m l a = + let l' = let l' = l in l' in + let m' = let m' = m in m' in + let u' = PositiveMap.update l' a m' in + (match u' with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some m'0 -> (fun _ -> m'0)) __ + +type identifier_set = Types.unit0 identifier_map + +(** val empty_set : PreIdentifiers.identifierTag -> identifier_set **) +let empty_set tag = + empty_map tag + +(** val add_set : + PreIdentifiers.identifierTag -> identifier_set -> + PreIdentifiers.identifier -> identifier_set **) +let add_set tag s i = + add tag s i Types.It + +(** val singleton_set : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + identifier_set **) +let singleton_set tag i = + add_set tag (empty_set tag) i + +(** val union_set : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a2 identifier_map + -> identifier_set **) +let rec union_set tag s s' = + PositiveMap.merge (fun o o' -> + match o with + | Types.None -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Option.option) (Obj.magic o') (fun x -> + Monad.m_return0 (Monad.max_def Option.option) Types.It)) + | Types.Some x -> Types.Some Types.It) (let s0 = s in s0) + (let s1 = s' in s1) + +(** val minus_set : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a2 identifier_map + -> 'a1 identifier_map **) +let rec minus_set tag s s' = + PositiveMap.merge (fun o o' -> + match o' with + | Types.None -> o + | Types.Some x -> Types.None) (let s0 = s in s0) (let s1 = s' in s1) + +(** val identifierSet : PreIdentifiers.identifierTag -> Setoids.setoid **) +let identifierSet tag = + Setoids.Mk_Setoid + +(** val id_map_size : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> Nat.nat **) +let id_map_size tag s = + let p = s in PositiveMap.domain_size p + +open Proper + +(** val set_from_list : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list -> + Types.unit0 identifier_map **) +let set_from_list tag = + Util.foldl (add_set tag) (empty_set tag) + +(** val dpi1__o__id_set_from_list__o__inject : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier List.list, + 'a1) Types.dPair -> Types.unit0 identifier_map Types.sig0 **) +let dpi1__o__id_set_from_list__o__inject x0 x3 = + set_from_list x0 x3.Types.dpi1 + +(** val eject__o__id_set_from_list__o__inject : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list + Types.sig0 -> Types.unit0 identifier_map Types.sig0 **) +let eject__o__id_set_from_list__o__inject x0 x3 = + set_from_list x0 (Types.pi1 x3) + +(** val id_set_from_list__o__inject : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list -> + Types.unit0 identifier_map Types.sig0 **) +let id_set_from_list__o__inject x0 x2 = + set_from_list x0 x2 + +(** val dpi1__o__id_set_from_list : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier List.list, + 'a1) Types.dPair -> Types.unit0 identifier_map **) +let dpi1__o__id_set_from_list x0 x2 = + set_from_list x0 x2.Types.dpi1 + +(** val eject__o__id_set_from_list : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list + Types.sig0 -> Types.unit0 identifier_map **) +let eject__o__id_set_from_list x0 x2 = + set_from_list x0 (Types.pi1 x2) + +(** val choose : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + ((PreIdentifiers.identifier, 'a1) Types.prod, 'a1 identifier_map) + Types.prod Types.option **) +let choose tag m = + match PositiveMap.pm_choose (let m' = m in m') with + | Types.None -> Types.None + | Types.Some x -> + Types.Some { Types.fst = { Types.fst = x.Types.fst.Types.fst; Types.snd = + x.Types.fst.Types.snd }; Types.snd = x.Types.snd } + +(** val try_remove : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> ('a1, 'a1 identifier_map) Types.prod + Types.option **) +let try_remove tag m id = + match PositiveMap.pm_try_remove (let id' = id in id') (let m' = m in m') with + | Types.None -> Types.None + | Types.Some x -> + Types.Some { Types.fst = x.Types.fst; Types.snd = x.Types.snd } + +(** val id_set_of_map : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> identifier_set **) +let id_set_of_map tag m = + PositiveMap.map (fun x -> Types.It) (let m' = m in m') + +(** val set_of_list : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list -> + identifier_set **) +let set_of_list tag l = + Util.foldl (fun s id -> add_set tag s id) (empty_set tag) l + +(** val domain_of_map : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> identifier_set **) +let domain_of_map tag m = + PositiveMap.domain_of_pm (let m0 = m in m0) + diff --git a/extracted/identifiers.mli b/extracted/identifiers.mli new file mode 100644 index 0000000..e91c416 --- /dev/null +++ b/extracted/identifiers.mli @@ -0,0 +1,320 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Positive + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Extralib + +open ErrorMessages + +open PreIdentifiers + +open Errors + +type universe = + Positive.pos + (* singleton inductive, whose constructor was mk_universe *) + +val universe_rect_Type4 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 + +val universe_rect_Type5 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 + +val universe_rect_Type3 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 + +val universe_rect_Type2 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 + +val universe_rect_Type1 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 + +val universe_rect_Type0 : + PreIdentifiers.identifierTag -> (Positive.pos -> 'a1) -> universe -> 'a1 + +val next_identifier : + PreIdentifiers.identifierTag -> universe -> Positive.pos + +val universe_inv_rect_Type4 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) -> + 'a1 + +val universe_inv_rect_Type3 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) -> + 'a1 + +val universe_inv_rect_Type2 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) -> + 'a1 + +val universe_inv_rect_Type1 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) -> + 'a1 + +val universe_inv_rect_Type0 : + PreIdentifiers.identifierTag -> universe -> (Positive.pos -> __ -> 'a1) -> + 'a1 + +val universe_discr : + PreIdentifiers.identifierTag -> universe -> universe -> __ + +val universe_jmdiscr : + PreIdentifiers.identifierTag -> universe -> universe -> __ + +val new_universe : PreIdentifiers.identifierTag -> universe + +val fresh : + PreIdentifiers.identifierTag -> universe -> (PreIdentifiers.identifier, + universe) Types.prod + +val eq_identifier : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + PreIdentifiers.identifier -> Bool.bool + +val eq_identifier_elim : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + PreIdentifiers.identifier -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +open Deqsets + +val deq_identifier : PreIdentifiers.identifierTag -> Deqsets.deqSet + +val word_of_identifier : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> Positive.pos + +val identifier_eq : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + PreIdentifiers.identifier -> (__, __) Types.sum + +val identifier_of_nat : + PreIdentifiers.identifierTag -> Nat.nat -> PreIdentifiers.identifier + +val check_member_env : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> + (PreIdentifiers.identifier, 'a1) Types.prod List.list -> __ Errors.res + +val check_distinct_env : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier, 'a1) Types.prod + List.list -> __ Errors.res + +open PositiveMap + +type 'a identifier_map = + 'a PositiveMap.positive_map + (* singleton inductive, whose constructor was an_id_map *) + +val identifier_map_rect_Type4 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 + +val identifier_map_rect_Type5 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 + +val identifier_map_rect_Type3 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 + +val identifier_map_rect_Type2 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 + +val identifier_map_rect_Type1 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 + +val identifier_map_rect_Type0 : + PreIdentifiers.identifierTag -> ('a1 PositiveMap.positive_map -> 'a2) -> + 'a1 identifier_map -> 'a2 + +val identifier_map_inv_rect_Type4 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 + +val identifier_map_inv_rect_Type3 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 + +val identifier_map_inv_rect_Type2 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 + +val identifier_map_inv_rect_Type1 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 + +val identifier_map_inv_rect_Type0 : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> ('a1 + PositiveMap.positive_map -> __ -> 'a2) -> 'a2 + +val identifier_map_discr : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a1 identifier_map -> + __ + +val identifier_map_jmdiscr : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a1 identifier_map -> + __ + +val empty_map : PreIdentifiers.identifierTag -> 'a1 identifier_map + +val lookup : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 Types.option + +val lookup_def : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 + +val member : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> Bool.bool + +val lookup_safe : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 + +val add : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 identifier_map + +val elements : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier, 'a1) Types.prod List.list + +val idmap_all : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier -> 'a1 -> __ -> Bool.bool) -> Bool.bool + +val update : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 identifier_map Errors.res + +val remove : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 identifier_map + +val foldi : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier -> 'a1 -> 'a2 -> + 'a2) -> 'a1 identifier_map -> 'a2 -> 'a2 + +val fold_inf : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier -> 'a1 -> __ -> 'a2 -> 'a2) -> 'a2 -> 'a2 + +val find : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + (PreIdentifiers.identifier -> 'a1 -> Bool.bool) -> + (PreIdentifiers.identifier, 'a1) Types.prod Types.option + +val lookup_present : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 + +val update_present : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> 'a1 -> 'a1 identifier_map + +type identifier_set = Types.unit0 identifier_map + +val empty_set : PreIdentifiers.identifierTag -> identifier_set + +val add_set : + PreIdentifiers.identifierTag -> identifier_set -> PreIdentifiers.identifier + -> identifier_set + +val singleton_set : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> identifier_set + +val union_set : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a2 identifier_map -> + identifier_set + +val minus_set : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> 'a2 identifier_map -> + 'a1 identifier_map + +val identifierSet : PreIdentifiers.identifierTag -> Setoids.setoid + +val id_map_size : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> Nat.nat + +open Proper + +val set_from_list : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list -> + Types.unit0 identifier_map + +val dpi1__o__id_set_from_list__o__inject : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier List.list, 'a1) + Types.dPair -> Types.unit0 identifier_map Types.sig0 + +val eject__o__id_set_from_list__o__inject : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list + Types.sig0 -> Types.unit0 identifier_map Types.sig0 + +val id_set_from_list__o__inject : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list -> + Types.unit0 identifier_map Types.sig0 + +val dpi1__o__id_set_from_list : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier List.list, 'a1) + Types.dPair -> Types.unit0 identifier_map + +val eject__o__id_set_from_list : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list + Types.sig0 -> Types.unit0 identifier_map + +val choose : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + ((PreIdentifiers.identifier, 'a1) Types.prod, 'a1 identifier_map) + Types.prod Types.option + +val try_remove : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> + PreIdentifiers.identifier -> ('a1, 'a1 identifier_map) Types.prod + Types.option + +val id_set_of_map : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> identifier_set + +val set_of_list : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier List.list -> + identifier_set + +val domain_of_map : + PreIdentifiers.identifierTag -> 'a1 identifier_map -> identifier_set + diff --git a/extracted/initialisation.ml b/extracted/initialisation.ml new file mode 100644 index 0000000..41890f2 --- /dev/null +++ b/extracted/initialisation.ml @@ -0,0 +1,214 @@ +open Preamble + +open CostLabel + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open FrontEndOps + +open Cminor_syntax + +open Extra_bool + +open Globalenvs + +(** val init_expr : + AST.init_data -> (AST.typ, Cminor_syntax.expr) Types.dPair Types.option **) +let init_expr = function +| AST.Init_int8 i -> + Types.Some { Types.dpi1 = (AST.ASTint (AST.I8, AST.Unsigned)); Types.dpi2 = + (Cminor_syntax.Cst ((AST.ASTint (AST.I8, AST.Unsigned)), + (FrontEndOps.Ointconst (AST.I8, AST.Unsigned, i)))) } +| AST.Init_int16 i -> + Types.Some { Types.dpi1 = (AST.ASTint (AST.I16, AST.Unsigned)); + Types.dpi2 = (Cminor_syntax.Cst ((AST.ASTint (AST.I16, AST.Unsigned)), + (FrontEndOps.Ointconst (AST.I16, AST.Unsigned, i)))) } +| AST.Init_int32 i -> + Types.Some { Types.dpi1 = (AST.ASTint (AST.I32, AST.Unsigned)); + Types.dpi2 = (Cminor_syntax.Cst ((AST.ASTint (AST.I32, AST.Unsigned)), + (FrontEndOps.Ointconst (AST.I32, AST.Unsigned, i)))) } +| AST.Init_space n -> Types.None +| AST.Init_null -> + Types.Some { Types.dpi1 = AST.ASTptr; Types.dpi2 = (Cminor_syntax.Op1 + ((AST.ASTint (AST.I8, AST.Unsigned)), AST.ASTptr, (FrontEndOps.Optrofint + (AST.I8, AST.Unsigned)), (Cminor_syntax.Cst ((AST.ASTint (AST.I8, + AST.Unsigned)), (FrontEndOps.Ointconst (AST.I8, AST.Unsigned, + (BitVector.zero (AST.bitsize_of_intsize AST.I8)))))))) } +| AST.Init_addrof (id, off) -> + Types.Some { Types.dpi1 = AST.ASTptr; Types.dpi2 = (Cminor_syntax.Cst + (AST.ASTptr, (FrontEndOps.Oaddrsymbol (id, off)))) } + +(** val option_jmdiscr : 'a1 Types.option -> 'a1 Types.option -> __ **) +let option_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Types.None -> Obj.magic (fun _ dH -> dH) + | Types.Some a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val dPair_jmdiscr : + ('a1, 'a2) Types.dPair -> ('a1, 'a2) Types.dPair -> __ **) +let dPair_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { Types.dpi1 = a0; Types.dpi2 = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val init_datum : + AST.ident -> AST.region -> AST.init_data -> Nat.nat -> Cminor_syntax.stmt + Types.sig0 **) +let init_datum id r init off = + (match init_expr init with + | Types.None -> (fun _ -> Cminor_syntax.St_skip) + | Types.Some x -> + (fun _ -> + (let { Types.dpi1 = t; Types.dpi2 = e } = x in + (fun _ -> Cminor_syntax.St_store (t, (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrsymbol (id, off)))), e))) __)) __ + +(** val init_var : + AST.ident -> AST.region -> AST.init_data List.list -> Cminor_syntax.stmt + Types.sig0 **) +let init_var id r init = + (Util.foldl (fun os datum -> + let { Types.fst = off; Types.snd = s } = os in + { Types.fst = (Nat.plus off (Globalenvs.size_init_data datum)); + Types.snd = (Cminor_syntax.St_seq + ((Types.pi1 (init_datum id r datum off)), s)) }) { Types.fst = Nat.O; + Types.snd = (Types.pi1 Cminor_syntax.St_skip) } init).Types.snd + +(** val init_vars : + ((AST.ident, AST.region) Types.prod, AST.init_data List.list) Types.prod + List.list -> Cminor_syntax.stmt Types.sig0 **) +let init_vars vars = + List.foldr (fun var s -> Cminor_syntax.St_seq ((Types.pi1 s), + (Types.pi1 + (init_var var.Types.fst.Types.fst var.Types.fst.Types.snd + var.Types.snd)))) Cminor_syntax.St_skip vars + +(** val add_statement : + CostLabel.costlabel -> AST.ident -> Cminor_syntax.stmt Types.sig0 -> + (AST.ident, Cminor_syntax.internal_function AST.fundef) Types.prod + List.list -> (AST.ident, Cminor_syntax.internal_function AST.fundef) + Types.prod List.list **) +let add_statement cost id s = + let s0 = s in + List.map (fun idf -> + let { Types.fst = id'; Types.snd = f' } = idf in + (match AST.ident_eq id id' with + | Types.Inl _ -> + (match f' with + | AST.Internal f -> + { Types.fst = id; Types.snd = (AST.Internal + { Cminor_syntax.f_return = f.Cminor_syntax.f_return; + Cminor_syntax.f_params = f.Cminor_syntax.f_params; + Cminor_syntax.f_vars = f.Cminor_syntax.f_vars; + Cminor_syntax.f_stacksize = f.Cminor_syntax.f_stacksize; + Cminor_syntax.f_body = (Cminor_syntax.St_cost (cost, + (Cminor_syntax.St_seq (s0, f.Cminor_syntax.f_body)))) }) } + | AST.External f -> { Types.fst = id; Types.snd = (AST.External f) }) + | Types.Inr _ -> { Types.fst = id'; Types.snd = f' })) + +(** val empty_vars : + ((AST.ident, AST.region) Types.prod, AST.init_data List.list) Types.prod + List.list -> ((AST.ident, AST.region) Types.prod, Nat.nat) Types.prod + List.list **) +let empty_vars = + List.map (fun v -> { Types.fst = { Types.fst = v.Types.fst.Types.fst; + Types.snd = v.Types.fst.Types.snd }; Types.snd = + (Globalenvs.size_init_data_list v.Types.snd) }) + +(** val replace_init : + CostLabel.costlabel -> Cminor_syntax.cminor_program -> + Cminor_syntax.cminor_noinit_program **) +let replace_init cost p = + { AST.prog_vars = (empty_vars p.AST.prog_vars); AST.prog_funct = + (add_statement cost p.AST.prog_main (init_vars p.AST.prog_vars) + p.AST.prog_funct); AST.prog_main = p.AST.prog_main } + diff --git a/extracted/initialisation.mli b/extracted/initialisation.mli new file mode 100644 index 0000000..b6f49cb --- /dev/null +++ b/extracted/initialisation.mli @@ -0,0 +1,136 @@ +open Preamble + +open CostLabel + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open FrontEndOps + +open Cminor_syntax + +open Extra_bool + +open Globalenvs + +val init_expr : + AST.init_data -> (AST.typ, Cminor_syntax.expr) Types.dPair Types.option + +val option_jmdiscr : 'a1 Types.option -> 'a1 Types.option -> __ + +val dPair_jmdiscr : ('a1, 'a2) Types.dPair -> ('a1, 'a2) Types.dPair -> __ + +val init_datum : + AST.ident -> AST.region -> AST.init_data -> Nat.nat -> Cminor_syntax.stmt + Types.sig0 + +val init_var : + AST.ident -> AST.region -> AST.init_data List.list -> Cminor_syntax.stmt + Types.sig0 + +val init_vars : + ((AST.ident, AST.region) Types.prod, AST.init_data List.list) Types.prod + List.list -> Cminor_syntax.stmt Types.sig0 + +val add_statement : + CostLabel.costlabel -> AST.ident -> Cminor_syntax.stmt Types.sig0 -> + (AST.ident, Cminor_syntax.internal_function AST.fundef) Types.prod + List.list -> (AST.ident, Cminor_syntax.internal_function AST.fundef) + Types.prod List.list + +val empty_vars : + ((AST.ident, AST.region) Types.prod, AST.init_data List.list) Types.prod + List.list -> ((AST.ident, AST.region) Types.prod, Nat.nat) Types.prod + List.list + +val replace_init : + CostLabel.costlabel -> Cminor_syntax.cminor_program -> + Cminor_syntax.cminor_noinit_program + diff --git a/extracted/integers.ml b/extracted/integers.ml new file mode 100644 index 0000000..2c8e19d --- /dev/null +++ b/extracted/integers.ml @@ -0,0 +1,367 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Types + +open Extranat + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Exp + +open Arithmetic + +type comparison = +| Ceq +| Cne +| Clt +| Cle +| Cgt +| Cge + +(** val comparison_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 **) +let rec comparison_rect_Type4 h_Ceq h_Cne h_Clt h_Cle h_Cgt h_Cge = function +| Ceq -> h_Ceq +| Cne -> h_Cne +| Clt -> h_Clt +| Cle -> h_Cle +| Cgt -> h_Cgt +| Cge -> h_Cge + +(** val comparison_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 **) +let rec comparison_rect_Type5 h_Ceq h_Cne h_Clt h_Cle h_Cgt h_Cge = function +| Ceq -> h_Ceq +| Cne -> h_Cne +| Clt -> h_Clt +| Cle -> h_Cle +| Cgt -> h_Cgt +| Cge -> h_Cge + +(** val comparison_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 **) +let rec comparison_rect_Type3 h_Ceq h_Cne h_Clt h_Cle h_Cgt h_Cge = function +| Ceq -> h_Ceq +| Cne -> h_Cne +| Clt -> h_Clt +| Cle -> h_Cle +| Cgt -> h_Cgt +| Cge -> h_Cge + +(** val comparison_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 **) +let rec comparison_rect_Type2 h_Ceq h_Cne h_Clt h_Cle h_Cgt h_Cge = function +| Ceq -> h_Ceq +| Cne -> h_Cne +| Clt -> h_Clt +| Cle -> h_Cle +| Cgt -> h_Cgt +| Cge -> h_Cge + +(** val comparison_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 **) +let rec comparison_rect_Type1 h_Ceq h_Cne h_Clt h_Cle h_Cgt h_Cge = function +| Ceq -> h_Ceq +| Cne -> h_Cne +| Clt -> h_Clt +| Cle -> h_Cle +| Cgt -> h_Cgt +| Cge -> h_Cge + +(** val comparison_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 **) +let rec comparison_rect_Type0 h_Ceq h_Cne h_Clt h_Cle h_Cgt h_Cge = function +| Ceq -> h_Ceq +| Cne -> h_Cne +| Clt -> h_Clt +| Cle -> h_Cle +| Cgt -> h_Cgt +| Cge -> h_Cge + +(** val comparison_inv_rect_Type4 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let comparison_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = comparison_rect_Type4 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val comparison_inv_rect_Type3 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let comparison_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 = + let hcut = comparison_rect_Type3 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val comparison_inv_rect_Type2 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let comparison_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 = + let hcut = comparison_rect_Type2 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val comparison_inv_rect_Type1 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let comparison_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 = + let hcut = comparison_rect_Type1 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val comparison_inv_rect_Type0 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let comparison_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 = + let hcut = comparison_rect_Type0 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val comparison_discr : comparison -> comparison -> __ **) +let comparison_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Ceq -> Obj.magic (fun _ dH -> dH) + | Cne -> Obj.magic (fun _ dH -> dH) + | Clt -> Obj.magic (fun _ dH -> dH) + | Cle -> Obj.magic (fun _ dH -> dH) + | Cgt -> Obj.magic (fun _ dH -> dH) + | Cge -> Obj.magic (fun _ dH -> dH)) y + +(** val comparison_jmdiscr : comparison -> comparison -> __ **) +let comparison_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Ceq -> Obj.magic (fun _ dH -> dH) + | Cne -> Obj.magic (fun _ dH -> dH) + | Clt -> Obj.magic (fun _ dH -> dH) + | Cle -> Obj.magic (fun _ dH -> dH) + | Cgt -> Obj.magic (fun _ dH -> dH) + | Cge -> Obj.magic (fun _ dH -> dH)) y + +(** val negate_comparison : comparison -> comparison **) +let negate_comparison = function +| Ceq -> Cne +| Cne -> Ceq +| Clt -> Cge +| Cle -> Cgt +| Cgt -> Cle +| Cge -> Clt + +(** val swap_comparison : comparison -> comparison **) +let swap_comparison = function +| Ceq -> Ceq +| Cne -> Cne +| Clt -> Cgt +| Cle -> Cge +| Cgt -> Clt +| Cge -> Cle + +(** val wordsize : Nat.nat **) +let wordsize = + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))))))))))))))))) + +type int = BitVector.bitVector + +(** val repr : Nat.nat -> int **) +let repr n = + Arithmetic.bitvector_of_nat wordsize n + +(** val zero : int **) +let zero = + repr Nat.O + +(** val one : int **) +let one = + repr (Nat.S Nat.O) + +(** val mone : BitVector.bitVector **) +let mone = + Arithmetic.subtraction wordsize zero one + +(** val iwordsize : int **) +let iwordsize = + repr wordsize + +(** val eq_dec : int -> int -> (__, __) Types.sum **) +let eq_dec x y = + (match BitVector.eq_bv wordsize x y with + | Bool.True -> (fun _ -> Types.Inl __) + | Bool.False -> (fun _ -> Types.Inr __)) __ + +(** val eq : int -> int -> Bool.bool **) +let eq = + BitVector.eq_bv wordsize + +(** val lt : int -> int -> Bool.bool **) +let lt = + Arithmetic.lt_s wordsize + +(** val ltu : int -> int -> Bool.bool **) +let ltu = + Arithmetic.lt_u wordsize + +(** val neg : int -> int **) +let neg = + Arithmetic.two_complement_negation wordsize + +(** val mul : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool Vector.vector **) +let mul x y = + (Vector.vsplit wordsize wordsize (Arithmetic.multiplication wordsize x y)).Types.snd + +(** val zero_ext_n : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let zero_ext_n w n = + match Extranat.nat_compare n w with + | Extranat.Nat_lt (n', w') -> + (fun i -> + let { Types.fst = h; Types.snd = l } = + Vector.vsplit (Nat.S w') n' (Vector.switch_bv_plus n' (Nat.S w') i) + in + Vector.switch_bv_plus (Nat.S w') n' (BitVector.pad (Nat.S w') n' l)) + | Extranat.Nat_eq x -> (fun i -> i) + | Extranat.Nat_gt (x, x0) -> (fun i -> i) + +(** val zero_ext : Nat.nat -> int -> int **) +let zero_ext = + zero_ext_n wordsize + +(** val sign_ext_n : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector **) +let sign_ext_n w n = + match Extranat.nat_compare n w with + | Extranat.Nat_lt (n', w') -> + (fun i -> + let { Types.fst = h; Types.snd = l } = + Vector.vsplit (Nat.S w') n' (Vector.switch_bv_plus n' (Nat.S w') i) + in + Vector.switch_bv_plus (Nat.S w') n' + (Vector.pad_vector + (match l with + | Vector.VEmpty -> Bool.False + | Vector.VCons (x, h0, x0) -> h0) (Nat.S w') n' l)) + | Extranat.Nat_eq x -> (fun i -> i) + | Extranat.Nat_gt (x, x0) -> (fun i -> i) + +(** val sign_ext : Nat.nat -> int -> int **) +let sign_ext = + sign_ext_n wordsize + +(** val i_and : int -> int -> int **) +let i_and = + BitVector.conjunction_bv wordsize + +(** val or0 : int -> int -> int **) +let or0 = + BitVector.inclusive_disjunction_bv wordsize + +(** val xor : int -> int -> int **) +let xor = + BitVector.exclusive_disjunction_bv wordsize + +(** val not : int -> int **) +let not = + BitVector.negation_bv wordsize + +(** val shl : int -> int -> int **) +let shl x y = + Vector.shift_left wordsize (Arithmetic.nat_of_bitvector wordsize y) x + Bool.False + +(** val shru : int -> int -> int **) +let shru x y = + Vector.shift_right (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))))))))))))))))) + (Arithmetic.nat_of_bitvector wordsize y) x Bool.False + +(** val shr : int -> int -> int **) +let shr x y = + Vector.shift_right (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))))))))))))))))) + (Arithmetic.nat_of_bitvector wordsize y) x + (Vector.head' (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))))))))))))))))) x) + +(** val shrx : int -> int -> int **) +let shrx x y = + match Arithmetic.division_s wordsize x (shl one y) with + | Types.None -> zero + | Types.Some i -> i + +(** val shr_carry : int -> int -> BitVector.bitVector **) +let shr_carry x y = + Arithmetic.subtraction wordsize (shrx x y) (shr x y) + +(** val rol : int -> int -> int **) +let rol x y = + Vector.rotate_left wordsize (Arithmetic.nat_of_bitvector wordsize y) x + +(** val ror : int -> int -> int **) +let ror x y = + Vector.rotate_right wordsize (Arithmetic.nat_of_bitvector wordsize y) x + +(** val rolm : int -> int -> int -> int **) +let rolm x a m = + i_and (rol x a) m + +(** val cmp : comparison -> int -> int -> Bool.bool **) +let cmp c x y = + match c with + | Ceq -> eq x y + | Cne -> Bool.notb (eq x y) + | Clt -> lt x y + | Cle -> Bool.notb (lt y x) + | Cgt -> lt y x + | Cge -> Bool.notb (lt x y) + +(** val cmpu : comparison -> int -> int -> Bool.bool **) +let cmpu c x y = + match c with + | Ceq -> eq x y + | Cne -> Bool.notb (eq x y) + | Clt -> ltu x y + | Cle -> Bool.notb (ltu y x) + | Cgt -> ltu y x + | Cge -> Bool.notb (ltu x y) + +(** val notbool : int -> int **) +let notbool x = + match eq x zero with + | Bool.True -> one + | Bool.False -> zero + diff --git a/extracted/integers.mli b/extracted/integers.mli new file mode 100644 index 0000000..3df704d --- /dev/null +++ b/extracted/integers.mli @@ -0,0 +1,167 @@ +open Preamble + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Types + +open Extranat + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Exp + +open Arithmetic + +type comparison = +| Ceq +| Cne +| Clt +| Cle +| Cgt +| Cge + +val comparison_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 + +val comparison_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 + +val comparison_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 + +val comparison_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 + +val comparison_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 + +val comparison_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> comparison -> 'a1 + +val comparison_inv_rect_Type4 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val comparison_inv_rect_Type3 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val comparison_inv_rect_Type2 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val comparison_inv_rect_Type1 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val comparison_inv_rect_Type0 : + comparison -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val comparison_discr : comparison -> comparison -> __ + +val comparison_jmdiscr : comparison -> comparison -> __ + +val negate_comparison : comparison -> comparison + +val swap_comparison : comparison -> comparison + +val wordsize : Nat.nat + +type int = BitVector.bitVector + +val repr : Nat.nat -> int + +val zero : int + +val one : int + +val mone : BitVector.bitVector + +val iwordsize : int + +val eq_dec : int -> int -> (__, __) Types.sum + +val eq : int -> int -> Bool.bool + +val lt : int -> int -> Bool.bool + +val ltu : int -> int -> Bool.bool + +val neg : int -> int + +val mul : + BitVector.bitVector -> BitVector.bitVector -> Bool.bool Vector.vector + +val zero_ext_n : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val zero_ext : Nat.nat -> int -> int + +val sign_ext_n : + Nat.nat -> Nat.nat -> BitVector.bitVector -> BitVector.bitVector + +val sign_ext : Nat.nat -> int -> int + +val i_and : int -> int -> int + +val or0 : int -> int -> int + +val xor : int -> int -> int + +val not : int -> int + +val shl : int -> int -> int + +val shru : int -> int -> int + +val shr : int -> int -> int + +val shrx : int -> int -> int + +val shr_carry : int -> int -> BitVector.bitVector + +val rol : int -> int -> int + +val ror : int -> int -> int + +val rolm : int -> int -> int -> int + +val cmp : comparison -> int -> int -> Bool.bool + +val cmpu : comparison -> int -> int -> Bool.bool + +val notbool : int -> int + diff --git a/extracted/interference.ml b/extracted/interference.ml new file mode 100644 index 0000000..d5f90cf --- /dev/null +++ b/extracted/interference.ml @@ -0,0 +1,314 @@ +open Preamble + +open Fixpoints + +open Set_adt + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open ERTL + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +open Liveness + +type decision = +| Decision_spill of Nat.nat +| Decision_colour of I8051.register + +(** val decision_rect_Type4 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 **) +let rec decision_rect_Type4 h_decision_spill h_decision_colour = function +| Decision_spill x_18946 -> h_decision_spill x_18946 +| Decision_colour x_18947 -> h_decision_colour x_18947 + +(** val decision_rect_Type5 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 **) +let rec decision_rect_Type5 h_decision_spill h_decision_colour = function +| Decision_spill x_18951 -> h_decision_spill x_18951 +| Decision_colour x_18952 -> h_decision_colour x_18952 + +(** val decision_rect_Type3 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 **) +let rec decision_rect_Type3 h_decision_spill h_decision_colour = function +| Decision_spill x_18956 -> h_decision_spill x_18956 +| Decision_colour x_18957 -> h_decision_colour x_18957 + +(** val decision_rect_Type2 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 **) +let rec decision_rect_Type2 h_decision_spill h_decision_colour = function +| Decision_spill x_18961 -> h_decision_spill x_18961 +| Decision_colour x_18962 -> h_decision_colour x_18962 + +(** val decision_rect_Type1 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 **) +let rec decision_rect_Type1 h_decision_spill h_decision_colour = function +| Decision_spill x_18966 -> h_decision_spill x_18966 +| Decision_colour x_18967 -> h_decision_colour x_18967 + +(** val decision_rect_Type0 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 **) +let rec decision_rect_Type0 h_decision_spill h_decision_colour = function +| Decision_spill x_18971 -> h_decision_spill x_18971 +| Decision_colour x_18972 -> h_decision_colour x_18972 + +(** val decision_inv_rect_Type4 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> + 'a1 **) +let decision_inv_rect_Type4 hterm h1 h2 = + let hcut = decision_rect_Type4 h1 h2 hterm in hcut __ + +(** val decision_inv_rect_Type3 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> + 'a1 **) +let decision_inv_rect_Type3 hterm h1 h2 = + let hcut = decision_rect_Type3 h1 h2 hterm in hcut __ + +(** val decision_inv_rect_Type2 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> + 'a1 **) +let decision_inv_rect_Type2 hterm h1 h2 = + let hcut = decision_rect_Type2 h1 h2 hterm in hcut __ + +(** val decision_inv_rect_Type1 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> + 'a1 **) +let decision_inv_rect_Type1 hterm h1 h2 = + let hcut = decision_rect_Type1 h1 h2 hterm in hcut __ + +(** val decision_inv_rect_Type0 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> + 'a1 **) +let decision_inv_rect_Type0 hterm h1 h2 = + let hcut = decision_rect_Type0 h1 h2 hterm in hcut __ + +(** val decision_discr : decision -> decision -> __ **) +let decision_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Decision_spill a0 -> Obj.magic (fun _ dH -> dH __) + | Decision_colour a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val decision_jmdiscr : decision -> decision -> __ **) +let decision_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Decision_spill a0 -> Obj.magic (fun _ dH -> dH __) + | Decision_colour a0 -> Obj.magic (fun _ dH -> dH __)) y + +type coloured_graph = { colouring : (Liveness.vertex -> decision); + spilled_no : Nat.nat } + +(** val coloured_graph_rect_Type4 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 **) +let rec coloured_graph_rect_Type4 before h_mk_coloured_graph x_19007 = + let { colouring = colouring0; spilled_no = spilled_no0 } = x_19007 in + h_mk_coloured_graph colouring0 spilled_no0 __ __ + +(** val coloured_graph_rect_Type5 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 **) +let rec coloured_graph_rect_Type5 before h_mk_coloured_graph x_19009 = + let { colouring = colouring0; spilled_no = spilled_no0 } = x_19009 in + h_mk_coloured_graph colouring0 spilled_no0 __ __ + +(** val coloured_graph_rect_Type3 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 **) +let rec coloured_graph_rect_Type3 before h_mk_coloured_graph x_19011 = + let { colouring = colouring0; spilled_no = spilled_no0 } = x_19011 in + h_mk_coloured_graph colouring0 spilled_no0 __ __ + +(** val coloured_graph_rect_Type2 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 **) +let rec coloured_graph_rect_Type2 before h_mk_coloured_graph x_19013 = + let { colouring = colouring0; spilled_no = spilled_no0 } = x_19013 in + h_mk_coloured_graph colouring0 spilled_no0 __ __ + +(** val coloured_graph_rect_Type1 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 **) +let rec coloured_graph_rect_Type1 before h_mk_coloured_graph x_19015 = + let { colouring = colouring0; spilled_no = spilled_no0 } = x_19015 in + h_mk_coloured_graph colouring0 spilled_no0 __ __ + +(** val coloured_graph_rect_Type0 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 **) +let rec coloured_graph_rect_Type0 before h_mk_coloured_graph x_19017 = + let { colouring = colouring0; spilled_no = spilled_no0 } = x_19017 in + h_mk_coloured_graph colouring0 spilled_no0 __ __ + +(** val colouring : + Fixpoints.valuation -> coloured_graph -> Liveness.vertex -> decision **) +let rec colouring before xxx = + xxx.colouring + +(** val spilled_no : Fixpoints.valuation -> coloured_graph -> Nat.nat **) +let rec spilled_no before xxx = + xxx.spilled_no + +(** val coloured_graph_inv_rect_Type4 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) + -> Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let coloured_graph_inv_rect_Type4 x1 hterm h1 = + let hcut = coloured_graph_rect_Type4 x1 h1 hterm in hcut __ + +(** val coloured_graph_inv_rect_Type3 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) + -> Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let coloured_graph_inv_rect_Type3 x1 hterm h1 = + let hcut = coloured_graph_rect_Type3 x1 h1 hterm in hcut __ + +(** val coloured_graph_inv_rect_Type2 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) + -> Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let coloured_graph_inv_rect_Type2 x1 hterm h1 = + let hcut = coloured_graph_rect_Type2 x1 h1 hterm in hcut __ + +(** val coloured_graph_inv_rect_Type1 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) + -> Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let coloured_graph_inv_rect_Type1 x1 hterm h1 = + let hcut = coloured_graph_rect_Type1 x1 h1 hterm in hcut __ + +(** val coloured_graph_inv_rect_Type0 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) + -> Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let coloured_graph_inv_rect_Type0 x1 hterm h1 = + let hcut = coloured_graph_rect_Type0 x1 h1 hterm in hcut __ + +(** val coloured_graph_discr : + Fixpoints.valuation -> coloured_graph -> coloured_graph -> __ **) +let coloured_graph_discr a1 x y = + Logic.eq_rect_Type2 x + (let { colouring = a0; spilled_no = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val coloured_graph_jmdiscr : + Fixpoints.valuation -> coloured_graph -> coloured_graph -> __ **) +let coloured_graph_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { colouring = a0; spilled_no = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +type coloured_graph_computer = + AST.ident List.list -> Joint.joint_internal_function -> Fixpoints.valuation + -> coloured_graph + diff --git a/extracted/interference.mli b/extracted/interference.mli new file mode 100644 index 0000000..d9e691a --- /dev/null +++ b/extracted/interference.mli @@ -0,0 +1,231 @@ +open Preamble + +open Fixpoints + +open Set_adt + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open ERTL + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +open Liveness + +type decision = +| Decision_spill of Nat.nat +| Decision_colour of I8051.register + +val decision_rect_Type4 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 + +val decision_rect_Type5 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 + +val decision_rect_Type3 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 + +val decision_rect_Type2 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 + +val decision_rect_Type1 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 + +val decision_rect_Type0 : + (Nat.nat -> 'a1) -> (I8051.register -> 'a1) -> decision -> 'a1 + +val decision_inv_rect_Type4 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> 'a1 + +val decision_inv_rect_Type3 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> 'a1 + +val decision_inv_rect_Type2 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> 'a1 + +val decision_inv_rect_Type1 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> 'a1 + +val decision_inv_rect_Type0 : + decision -> (Nat.nat -> __ -> 'a1) -> (I8051.register -> __ -> 'a1) -> 'a1 + +val decision_discr : decision -> decision -> __ + +val decision_jmdiscr : decision -> decision -> __ + +type coloured_graph = { colouring : (Liveness.vertex -> decision); + spilled_no : Nat.nat } + +val coloured_graph_rect_Type4 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 + +val coloured_graph_rect_Type5 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 + +val coloured_graph_rect_Type3 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 + +val coloured_graph_rect_Type2 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 + +val coloured_graph_rect_Type1 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 + +val coloured_graph_rect_Type0 : + Fixpoints.valuation -> ((Liveness.vertex -> decision) -> Nat.nat -> __ -> + __ -> 'a1) -> coloured_graph -> 'a1 + +val colouring : + Fixpoints.valuation -> coloured_graph -> Liveness.vertex -> decision + +val spilled_no : Fixpoints.valuation -> coloured_graph -> Nat.nat + +val coloured_graph_inv_rect_Type4 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val coloured_graph_inv_rect_Type3 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val coloured_graph_inv_rect_Type2 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val coloured_graph_inv_rect_Type1 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val coloured_graph_inv_rect_Type0 : + Fixpoints.valuation -> coloured_graph -> ((Liveness.vertex -> decision) -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val coloured_graph_discr : + Fixpoints.valuation -> coloured_graph -> coloured_graph -> __ + +val coloured_graph_jmdiscr : + Fixpoints.valuation -> coloured_graph -> coloured_graph -> __ + +type coloured_graph_computer = + AST.ident List.list -> Joint.joint_internal_function -> Fixpoints.valuation + -> coloured_graph + diff --git a/extracted/interpret.ml b/extracted/interpret.ml new file mode 100644 index 0000000..30e9141 --- /dev/null +++ b/extracted/interpret.ml @@ -0,0 +1,4348 @@ +open Preamble + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +(** val execute_1_preinstruction : + (Nat.nat, Nat.nat) Types.prod -> 'a2 -> ('a1 -> 'a2 Status.preStatus -> + BitVector.word) -> 'a1 ASM.preinstruction -> 'a2 Status.preStatus -> 'a2 + Status.preStatus **) +let execute_1_preinstruction ticks cm addr_of instr s = + let add_ticks1 = fun s0 -> + Status.set_clock cm s0 (Nat.plus ticks.Types.fst s0.Status.clock) + in + let add_ticks2 = fun s0 -> + Status.set_clock cm s0 (Nat.plus ticks.Types.snd s0.Status.clock) + in + (match instr with + | ASM.ADD (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let { Types.fst = result; Types.snd = flags } = + Arithmetic.add_8_with_carry + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S + Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) Bool.False + in + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags in + let ac_flag = Vector.get_index' (Nat.S Nat.O) (Nat.S Nat.O) flags in + let ov_flag = Vector.get_index' (Nat.S (Nat.S Nat.O)) Nat.O flags in + let s1 = Status.set_arg_8 cm s0 ASM.ACC_A result in + Status.set_flags cm s1 cy_flag (Types.Some ac_flag) ov_flag) + | ASM.ADDC (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + let { Types.fst = result; Types.snd = flags } = + Arithmetic.add_8_with_carry + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S + Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) old_cy_flag + in + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags in + let ac_flag = Vector.get_index' (Nat.S Nat.O) (Nat.S Nat.O) flags in + let ov_flag = Vector.get_index' (Nat.S (Nat.S Nat.O)) Nat.O flags in + let s1 = Status.set_arg_8 cm s0 ASM.ACC_A result in + Status.set_flags cm s1 cy_flag (Types.Some ac_flag) ov_flag) + | ASM.SUBB (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + let { Types.fst = result; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S + Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) old_cy_flag + in + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags in + let ac_flag = Vector.get_index' (Nat.S Nat.O) (Nat.S Nat.O) flags in + let ov_flag = Vector.get_index' (Nat.S (Nat.S Nat.O)) Nat.O flags in + let s1 = Status.set_arg_8 cm s0 ASM.ACC_A result in + Status.set_flags cm s1 cy_flag (Types.Some ac_flag) ov_flag) + | ASM.INC addr -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Direct, (Vector.VCons ((Nat.S Nat.O), ASM.Indirect, + (Vector.VCons (Nat.O, ASM.Dptr, Vector.VEmpty)))))))))) addr with + | ASM.DIRECT d -> + (fun _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True (ASM.DIRECT d)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' (ASM.DIRECT d) result) + | ASM.INDIRECT i -> + (fun _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True (ASM.INDIRECT i)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' (ASM.INDIRECT i) result) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True (ASM.REGISTER r)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' (ASM.REGISTER r) result) + | ASM.ACC_A -> + (fun _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True ASM.ACC_A) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' ASM.ACC_A result) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> + (fun _ -> + let s' = add_ticks1 s in + let { Types.fst = carry; Types.snd = bl } = + Arithmetic.half_add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s' Status.SFR_DPL) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let { Types.fst = carry0; Types.snd = bu } = + Arithmetic.full_add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s' Status.SFR_DPH) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) carry + in + let s'' = Status.set_8051_sfr cm s' Status.SFR_DPL bl in + Status.set_8051_sfr cm s'' Status.SFR_DPH bu) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | ASM.DEC addr -> + (fun _ -> + let s0 = add_ticks1 s in + let { Types.fst = result; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Registr, (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Registr, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons (Nat.O, + ASM.Indirect, Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr) result) + | ASM.MUL (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let acc_a_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + let acc_b_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_B) + in + let product = Nat.times acc_a_nat acc_b_nat in + let low = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.modulus product (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + in + let high = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.division product (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A low in + Status.set_8051_sfr cm s1 Status.SFR_ACC_B high) + | ASM.DIV (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let acc_a_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + let acc_b_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_B) + in + (match acc_b_nat with + | Nat.O -> Status.set_flags cm s0 Bool.False Types.None Bool.True + | Nat.S o -> + let q = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.division acc_a_nat (Nat.S o)) + in + let r = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.modulus acc_a_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A q in + let s2 = Status.set_8051_sfr cm s1 Status.SFR_ACC_B r in + Status.set_flags cm s2 Bool.False Types.None Bool.False)) + | ASM.DA addr -> + (fun _ -> + let s0 = add_ticks1 s in + let { Types.fst = acc_nu; Types.snd = acc_nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + (match Bool.orb + (Util.gtb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) acc_nl) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) + (Status.get_ac_flag cm s0) with + | Bool.True -> + let { Types.fst = result; Types.snd = flags } = + Arithmetic.add_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))) Bool.False + in + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags + in + let { Types.fst = acc_nu'; Types.snd = acc_nl' } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) result + in + (match Bool.orb + (Util.gtb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) acc_nu') (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) cy_flag with + | Bool.True -> + let nu = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) acc_nu' + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + in + let new_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))) nu acc_nl' + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc in + Status.set_flags cm s1 cy_flag (Types.Some + (Status.get_ac_flag cm s1)) (Status.get_ov_flag cm s1) + | Bool.False -> s0) + | Bool.False -> s0)) + | ASM.JC addr -> + (fun _ -> + match Status.get_cy_flag cm s with + | Bool.True -> + let s0 = add_ticks1 s in + Status.set_program_counter cm s0 (addr_of addr s0) + | Bool.False -> let s0 = add_ticks2 s in s0) + | ASM.JNC addr -> + (fun _ -> + match Bool.notb (Status.get_cy_flag cm s) with + | Bool.True -> + let s0 = add_ticks1 s in + Status.set_program_counter cm s0 (addr_of addr s0) + | Bool.False -> let s0 = add_ticks2 s in s0) + | ASM.JB (addr1, addr2) -> + (fun _ -> + match Status.get_arg_1 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr1) + Bool.False with + | Bool.True -> + let s0 = add_ticks1 s in + Status.set_program_counter cm s0 (addr_of addr2 s0) + | Bool.False -> let s0 = add_ticks2 s in s0) + | ASM.JNB (addr1, addr2) -> + (fun _ -> + match Bool.notb + (Status.get_arg_1 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), + ASM.N_bit_addr, (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)))))) addr1) Bool.False) with + | Bool.True -> + let s0 = add_ticks1 s in + Status.set_program_counter cm s0 (addr_of addr2 s0) + | Bool.False -> let s0 = add_ticks2 s in s0) + | ASM.JBC (addr1, addr2) -> + (fun _ -> + let s0 = + Status.set_arg_1 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + Nat.O) (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)) + (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, (Vector.VCons + (Nat.O, ASM.Carry, Vector.VEmpty)))) addr1) Bool.False + in + (match Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr1) + Bool.False with + | Bool.True -> + let s1 = add_ticks1 s0 in + Status.set_program_counter cm s1 (addr_of addr2 s1) + | Bool.False -> let s1 = add_ticks2 s0 in s1)) + | ASM.JZ addr -> + (fun _ -> + match BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s Status.SFR_ACC_A) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) with + | Bool.True -> + let s0 = add_ticks1 s in + Status.set_program_counter cm s0 (addr_of addr s0) + | Bool.False -> let s0 = add_ticks2 s in s0) + | ASM.JNZ addr -> + (fun _ -> + match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s Status.SFR_ACC_A) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))) with + | Bool.True -> + let s0 = add_ticks1 s in + Status.set_program_counter cm s0 (addr_of addr s0) + | Bool.False -> let s0 = add_ticks2 s in s0) + | ASM.CJNE (addr1, addr2) -> + (fun _ -> + match addr1 with + | Types.Inl l -> + let { Types.fst = addr10; Types.snd = addr2' } = l in + let new_cy = + Util.ltb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr10))) + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Direct, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2'))) + in + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + (Nat.O, ASM.Acc_a, Vector.VEmpty)) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr10)) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Data, Vector.VEmpty)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2'))) with + | Bool.True -> + let s0 = add_ticks1 s in + let s1 = Status.set_program_counter cm s0 (addr_of addr2 s0) in + Status.set_flags cm s1 new_cy Types.None + (Status.get_ov_flag cm s1) + | Bool.False -> + let s0 = add_ticks2 s in + Status.set_flags cm s0 new_cy Types.None + (Status.get_ov_flag cm s0)) + | Types.Inr r' -> + let { Types.fst = addr10; Types.snd = addr2' } = r' in + let new_cy = + Util.ltb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr10))) + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2'))) + in + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Registr, + (Vector.VCons (Nat.O, ASM.Indirect, Vector.VEmpty)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr10)) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + (Nat.O, ASM.Data, Vector.VEmpty)) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2'))) with + | Bool.True -> + let s0 = add_ticks1 s in + let s1 = Status.set_program_counter cm s0 (addr_of addr2 s0) in + Status.set_flags cm s1 new_cy Types.None + (Status.get_ov_flag cm s1) + | Bool.False -> + let s0 = add_ticks2 s in + Status.set_flags cm s0 new_cy Types.None + (Status.get_ov_flag cm s0))) + | ASM.DJNZ (addr1, addr2) -> + (fun _ -> + let { Types.fst = result; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_arg_8 cm s Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + let s0 = + Status.set_arg_8 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S Nat.O) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Registr, (Vector.VCons (Nat.O, + ASM.Direct, Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) result + in + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) result + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))) with + | Bool.True -> + let s1 = add_ticks1 s0 in + Status.set_program_counter cm s1 (addr_of addr2 s1) + | Bool.False -> let s1 = add_ticks2 s0 in s1)) + | ASM.ANL addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + (match l with + | Types.Inl l' -> + let { Types.fst = addr1; Types.snd = addr2 } = l' in + let and_val = + BitVector.conjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Direct, (Vector.VCons ((Nat.S Nat.O), ASM.Indirect, + (Vector.VCons (Nat.O, ASM.Data, Vector.VEmpty)))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Acc_a, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) and_val + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let and_val = + BitVector.conjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Direct, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) and_val) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let and_val = + Bool.andb (Status.get_cy_flag cm s0) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S Nat.O), + ASM.Bit_addr, (Vector.VCons (Nat.O, ASM.N_bit_addr, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr2) + Bool.True) + in + Status.set_flags cm s0 and_val Types.None + (Status.get_ov_flag cm s0))) + | ASM.ORL addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + (match l with + | Types.Inl l' -> + let { Types.fst = addr1; Types.snd = addr2 } = l' in + let or_val = + BitVector.inclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Data, (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Acc_a, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) or_val + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let or_val = + BitVector.inclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Direct, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) or_val) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let or_val = + Bool.orb (Status.get_cy_flag cm s0) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S Nat.O), + ASM.Bit_addr, (Vector.VCons (Nat.O, ASM.N_bit_addr, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr2) + Bool.True) + in + Status.set_flags cm s0 or_val Types.None (Status.get_ov_flag cm s0))) + | ASM.XRL addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l' -> + let { Types.fst = addr1; Types.snd = addr2 } = l' in + let xor_val = + BitVector.exclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Registr, (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Acc_a, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) xor_val + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let xor_val = + BitVector.exclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Direct, Vector.VEmpty)) (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) xor_val)) + | ASM.CLR addr -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S + Nat.O), ASM.Carry, (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)))))) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> + let s0 = add_ticks1 s in + Status.set_arg_8 cm s0 ASM.ACC_A + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> + let s0 = add_ticks1 s in + Status.set_arg_1 cm s0 ASM.CARRY Bool.False) + | ASM.BIT_ADDR b -> + (fun _ -> + let s0 = add_ticks1 s in + Status.set_arg_1 cm s0 (ASM.BIT_ADDR b) Bool.False) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | ASM.CPL addr -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S + Nat.O), ASM.Carry, (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)))))) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_acc = + BitVector.negation_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) old_acc + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_arg_1 cm s0 ASM.CARRY Bool.True in + let new_cy_flag = Bool.notb old_cy_flag in + Status.set_arg_1 cm s0 ASM.CARRY new_cy_flag) + | ASM.BIT_ADDR b -> + (fun _ -> + let s0 = add_ticks1 s in + let old_bit = Status.get_arg_1 cm s0 (ASM.BIT_ADDR b) Bool.True + in + let new_bit = Bool.notb old_bit in + Status.set_arg_1 cm s0 (ASM.BIT_ADDR b) new_bit) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | ASM.RL x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_acc = + Vector.rotate_left (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S Nat.O) old_acc + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc) + | ASM.RLC x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_cy_flag = + Vector.get_index' Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) old_acc + in + let new_acc = + Vector.shift_left (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S Nat.O) old_acc old_cy_flag + in + let s1 = Status.set_arg_1 cm s0 ASM.CARRY new_cy_flag in + Status.set_8051_sfr cm s1 Status.SFR_ACC_A new_acc) + | ASM.RR x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_acc = + Vector.rotate_right (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S Nat.O) old_acc + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc) + | ASM.RRC x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_cy_flag = + Vector.get_index' (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) Nat.O old_acc + in + let new_acc = + Vector.shift_right (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) (Nat.S Nat.O) old_acc old_cy_flag + in + let s1 = Status.set_arg_1 cm s0 ASM.CARRY new_cy_flag in + Status.set_8051_sfr cm s1 Status.SFR_ACC_A new_acc) + | ASM.SWAP x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let { Types.fst = nu; Types.snd = nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) old_acc + in + let new_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) nl nu + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc) + | ASM.MOV addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + (match l with + | Types.Inl l' -> + (match l' with + | Types.Inl l'' -> + (match l'' with + | Types.Inl l''' -> + (match l''' with + | Types.Inl l'''' -> + let { Types.fst = addr1; Types.snd = addr2 } = l'''' in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Indirect, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) + addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons + ((Nat.S Nat.O), ASM.Indirect, (Vector.VCons + (Nat.O, ASM.Data, Vector.VEmpty)))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Data, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) + | Types.Inr r'''' -> + let { Types.fst = addr1; Types.snd = addr2 } = r'''' in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2))) + | Types.Inr r''' -> + let { Types.fst = addr1; Types.snd = addr2 } = r''' in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons + ((Nat.S Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, + ASM.Data, Vector.VEmpty)))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2))) + | Types.Inr r'' -> + let { Types.fst = addr1; Types.snd = addr2 } = r'' in + Status.set_arg_16 cm s0 + (Status.get_arg_16 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S Nat.O) (Vector.VCons (Nat.O, ASM.Data16, + Vector.VEmpty)) (Vector.VCons ((Nat.S Nat.O), + ASM.Data16, (Vector.VCons (Nat.O, ASM.Acc_dptr, + Vector.VEmpty)))) addr2)) addr1) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + Status.set_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S Nat.O) (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)) (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))) addr1) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), + ASM.N_bit_addr, (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)))))) addr2) Bool.False)) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + Status.set_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + Nat.O) (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)) + (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, (Vector.VCons + (Nat.O, ASM.Carry, Vector.VEmpty)))) addr1) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr2) + Bool.False))) + | ASM.MOVX addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + let { Types.fst = addr1; Types.snd = addr2 } = l in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Acc_a, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))), ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S Nat.O) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, Vector.VEmpty)))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)))) + | ASM.SETB b -> + (fun _ -> + let s0 = add_ticks1 s in + Status.set_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S Nat.O) + (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), ASM.Carry, + (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)))) + (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, (Vector.VCons (Nat.O, + ASM.Carry, Vector.VEmpty)))) b) Bool.False) + | ASM.PUSH addr -> + (fun _ -> + let s0 = add_ticks1 s in + let new_sp = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + Status.write_at_stack_pointer cm s1 + (Status.get_arg_8 cm s1 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Direct, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr))) + | ASM.POP addr -> + (fun _ -> + let s0 = add_ticks1 s in + let contents = Status.read_at_stack_pointer cm s0 in + let { Types.fst = new_sp; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + Status.set_arg_8 cm s1 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Direct, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr) contents) + | ASM.XCH (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let old_addr = + Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Registr, (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Indirect, Vector.VEmpty)))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2) + in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A old_addr in + Status.set_arg_8 cm s1 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Registr, (Vector.VCons + ((Nat.S Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr2) old_acc) + | ASM.XCHD (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let { Types.fst = acc_nu; Types.snd = acc_nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + let { Types.fst = arg_nu; Types.snd = arg_nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) + in + let new_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) acc_nu arg_nl + in + let new_arg = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) arg_nu acc_nl + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc in + Status.set_arg_8 cm s1 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Indirect, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr2) new_arg) + | ASM.RET -> + (fun _ -> + let s0 = add_ticks1 s in + let high_bits = Status.read_at_stack_pointer cm s0 in + let { Types.fst = new_sp; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + let low_bits = Status.read_at_stack_pointer cm s1 in + let { Types.fst = new_sp0; Types.snd = flags0 } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s1 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + let s2 = Status.set_8051_sfr cm s1 Status.SFR_SP new_sp0 in + let new_pc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) high_bits low_bits + in + Status.set_program_counter cm s2 new_pc) + | ASM.RETI -> + (fun _ -> + let s0 = add_ticks1 s in + let high_bits = Status.read_at_stack_pointer cm s0 in + let { Types.fst = new_sp; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + let low_bits = Status.read_at_stack_pointer cm s1 in + let { Types.fst = new_sp0; Types.snd = flags0 } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s1 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + let s2 = Status.set_8051_sfr cm s1 Status.SFR_SP new_sp0 in + let new_pc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) high_bits low_bits + in + Status.set_program_counter cm s2 new_pc) + | ASM.NOP -> (fun _ -> let s0 = add_ticks1 s in s0) + | ASM.JMP acc_dptr -> + (fun _ -> + let s0 = add_ticks1 s in + let jmp_addr = + Status.get_arg_16 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + Nat.O) (Vector.VCons (Nat.O, ASM.Acc_dptr, Vector.VEmpty)) + (Vector.VCons ((Nat.S Nat.O), ASM.Data16, (Vector.VCons (Nat.O, + ASM.Acc_dptr, Vector.VEmpty)))) acc_dptr) + in + Status.set_program_counter cm s0 jmp_addr)) __ + +(** val execute_1_preinstruction_ok' : + (Nat.nat, Nat.nat) Types.prod -> 'a2 -> ('a1 -> 'a2 Status.preStatus -> + BitVector.word) -> 'a1 ASM.preinstruction -> 'a2 Status.preStatus -> 'a2 + Status.preStatus Types.sig0 **) +let execute_1_preinstruction_ok' ticks cm addr_of instr s = + let add_ticks1 = fun s0 -> + Status.set_clock cm s0 (Nat.plus ticks.Types.fst s0.Status.clock) + in + let add_ticks2 = fun s0 -> + Status.set_clock cm s0 (Nat.plus ticks.Types.snd s0.Status.clock) + in + (match instr with + | ASM.ADD (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + (let { Types.fst = result; Types.snd = flags } = + Arithmetic.add_8_with_carry + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S + Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) Bool.False + in + (fun _ -> + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags in + let ac_flag = Vector.get_index' (Nat.S Nat.O) (Nat.S Nat.O) flags in + let ov_flag = Vector.get_index' (Nat.S (Nat.S Nat.O)) Nat.O flags in + let s1 = Status.set_arg_8 cm s0 ASM.ACC_A result in + Status.set_flags cm s1 cy_flag (Types.Some ac_flag) ov_flag)) __) + | ASM.ADDC (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + (let { Types.fst = result; Types.snd = flags } = + Arithmetic.add_8_with_carry + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S + Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) old_cy_flag + in + (fun _ -> + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags in + let ac_flag = Vector.get_index' (Nat.S Nat.O) (Nat.S Nat.O) flags in + let ov_flag = Vector.get_index' (Nat.S (Nat.S Nat.O)) Nat.O flags in + let s1 = Status.set_arg_8 cm s0 ASM.ACC_A result in + Status.set_flags cm s1 cy_flag (Types.Some ac_flag) ov_flag)) __) + | ASM.SUBB (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + (let { Types.fst = result; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons ((Nat.S + Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) old_cy_flag + in + (fun _ -> + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags in + let ac_flag = Vector.get_index' (Nat.S Nat.O) (Nat.S Nat.O) flags in + let ov_flag = Vector.get_index' (Nat.S (Nat.S Nat.O)) Nat.O flags in + let s1 = Status.set_arg_8 cm s0 ASM.ACC_A result in + Status.set_flags cm s1 cy_flag (Types.Some ac_flag) ov_flag)) __) + | ASM.INC addr -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Direct, (Vector.VCons ((Nat.S Nat.O), ASM.Indirect, + (Vector.VCons (Nat.O, ASM.Dptr, Vector.VEmpty)))))))))) addr with + | ASM.DIRECT d -> + (fun _ _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True (ASM.DIRECT d)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' (ASM.DIRECT d) result) + | ASM.INDIRECT i -> + (fun _ _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True (ASM.INDIRECT i)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' (ASM.INDIRECT i) result) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True (ASM.REGISTER r)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' (ASM.REGISTER r) result) + | ASM.ACC_A -> + (fun _ _ -> + let s' = add_ticks1 s in + let result = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s' Bool.True ASM.ACC_A) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + Status.set_arg_8 cm s' ASM.ACC_A result) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> + (fun _ _ -> + let s' = add_ticks1 s in + (let { Types.fst = carry; Types.snd = bl } = + Arithmetic.half_add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s' Status.SFR_DPL) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + (fun _ -> + (let { Types.fst = carry0; Types.snd = bu } = + Arithmetic.full_add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s' Status.SFR_DPH) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) carry + in + (fun _ -> + let s1 = Status.set_8051_sfr cm s' Status.SFR_DPL bl in + Status.set_8051_sfr cm s1 Status.SFR_DPH bu)) __)) __) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ __) + | ASM.DEC addr -> + (fun _ -> + let s0 = add_ticks1 s in + (let { Types.fst = result; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Registr, (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + (fun _ -> + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Registr, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons (Nat.O, + ASM.Indirect, Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr) result)) + __) + | ASM.MUL (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let acc_a_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + let acc_b_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_B) + in + let product = Nat.times acc_a_nat acc_b_nat in + let low = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.modulus product (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + in + let high = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.division product (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A low in + Status.set_8051_sfr cm s1 Status.SFR_ACC_B high) + | ASM.DIV (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let acc_a_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + let acc_b_nat = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_B) + in + (match acc_b_nat with + | Nat.O -> + (fun _ -> Status.set_flags cm s0 Bool.False Types.None Bool.True) + | Nat.S o -> + (fun _ -> + let q = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.division acc_a_nat (Nat.S o)) + in + let r = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Util.modulus acc_a_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A q in + let s2 = Status.set_8051_sfr cm s1 Status.SFR_ACC_B r in + Status.set_flags cm s2 Bool.False Types.None Bool.False)) __) + | ASM.DA addr -> + (fun _ -> + let s0 = add_ticks1 s in + (let { Types.fst = acc_nu; Types.snd = acc_nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + (fun _ -> + (match Bool.orb + (Util.gtb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) acc_nl) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) + (Status.get_ac_flag cm s0) with + | Bool.True -> + (fun _ -> + (let { Types.fst = result; Types.snd = flags } = + Arithmetic.add_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))) Bool.False + in + (fun _ -> + let cy_flag = Vector.get_index' Nat.O (Nat.S (Nat.S Nat.O)) flags + in + (let { Types.fst = acc_nu'; Types.snd = acc_nl' } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))) result + in + (fun _ -> + (match Bool.orb + (Util.gtb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))) acc_nu') (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) cy_flag with + | Bool.True -> + (fun _ -> + let nu = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + acc_nu' + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + in + let new_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))) nu acc_nl' + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc + in + Status.set_flags cm s1 cy_flag (Types.Some + (Status.get_ac_flag cm s1)) (Status.get_ov_flag cm s1)) + | Bool.False -> (fun _ -> s0)) __)) __)) __) + | Bool.False -> (fun _ -> s0)) __)) __) + | ASM.JC addr -> + (fun _ -> + (match Status.get_cy_flag cm s with + | Bool.True -> + (fun _ -> + let s1 = add_ticks1 s in + Status.set_program_counter cm s1 (addr_of addr s1)) + | Bool.False -> (fun _ -> let s1 = add_ticks2 s in s1)) __) + | ASM.JNC addr -> + (fun _ -> + (match Bool.notb (Status.get_cy_flag cm s) with + | Bool.True -> + (fun _ -> + let s1 = add_ticks1 s in + Status.set_program_counter cm s1 (addr_of addr s1)) + | Bool.False -> (fun _ -> let s1 = add_ticks2 s in s1)) __) + | ASM.JB (addr1, addr2) -> + (fun _ -> + (match Status.get_arg_1 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr1) + Bool.False with + | Bool.True -> + (fun _ -> + let s1 = add_ticks1 s in + Status.set_program_counter cm s1 (addr_of addr2 s1)) + | Bool.False -> (fun _ -> let s1 = add_ticks2 s in s1)) __) + | ASM.JNB (addr1, addr2) -> + (fun _ -> + (match Bool.notb + (Status.get_arg_1 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), + ASM.N_bit_addr, (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)))))) addr1) Bool.False) with + | Bool.True -> + (fun _ -> + let s1 = add_ticks1 s in + Status.set_program_counter cm s1 (addr_of addr2 s1)) + | Bool.False -> (fun _ -> let s1 = add_ticks2 s in s1)) __) + | ASM.JBC (addr1, addr2) -> + (fun _ -> + let s0 = + Status.set_arg_1 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + Nat.O) (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)) + (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, (Vector.VCons + (Nat.O, ASM.Carry, Vector.VEmpty)))) addr1) Bool.False + in + (match Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr1) + Bool.False with + | Bool.True -> + (fun _ -> + let s1 = add_ticks1 s0 in + Status.set_program_counter cm s1 (addr_of addr2 s1)) + | Bool.False -> (fun _ -> let s1 = add_ticks2 s0 in s1)) __) + | ASM.JZ addr -> + (fun _ -> + (match BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s Status.SFR_ACC_A) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) with + | Bool.True -> + (fun _ -> + let s1 = add_ticks1 s in + Status.set_program_counter cm s1 (addr_of addr s1)) + | Bool.False -> (fun _ -> let s1 = add_ticks2 s in s1)) __) + | ASM.JNZ addr -> + (fun _ -> + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s Status.SFR_ACC_A) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))) with + | Bool.True -> + (fun _ -> + let s1 = add_ticks1 s in + Status.set_program_counter cm s1 (addr_of addr s1)) + | Bool.False -> (fun _ -> let s1 = add_ticks2 s in s1)) __) + | ASM.CJNE (addr1, addr2) -> + (fun _ -> + match addr1 with + | Types.Inl l -> + let { Types.fst = addr10; Types.snd = addr2' } = l in + let new_cy = + Util.ltb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr10))) + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Direct, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2'))) + in + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + (Nat.O, ASM.Acc_a, Vector.VEmpty)) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr10)) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Data, Vector.VEmpty)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2'))) with + | Bool.True -> + let s0 = add_ticks1 s in + let s1 = Status.set_program_counter cm s0 (addr_of addr2 s0) in + Status.set_flags cm s1 new_cy Types.None + (Status.get_ov_flag cm s1) + | Bool.False -> + let s0 = add_ticks2 s in + Status.set_flags cm s0 new_cy Types.None + (Status.get_ov_flag cm s0)) + | Types.Inr r' -> + let { Types.fst = addr10; Types.snd = addr2' } = r' in + let new_cy = + Util.ltb + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr10))) + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2'))) + in + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Registr, + (Vector.VCons (Nat.O, ASM.Indirect, Vector.VEmpty)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr10)) + (Status.get_arg_8 cm s Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + (Nat.O, ASM.Data, Vector.VEmpty)) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2'))) with + | Bool.True -> + let s0 = add_ticks1 s in + let s1 = Status.set_program_counter cm s0 (addr_of addr2 s0) in + Status.set_flags cm s1 new_cy Types.None + (Status.get_ov_flag cm s1) + | Bool.False -> + let s0 = add_ticks2 s in + Status.set_flags cm s0 new_cy Types.None + (Status.get_ov_flag cm s0))) + | ASM.DJNZ (addr1, addr2) -> + (fun _ -> + (let { Types.fst = result; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_arg_8 cm s Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr1)) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + (fun _ -> + let s1 = + Status.set_arg_8 cm s + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S Nat.O) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Registr, (Vector.VCons (Nat.O, + ASM.Direct, Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) result + in + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) result + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))) with + | Bool.True -> + (fun _ -> + let s2 = add_ticks1 s1 in + Status.set_program_counter cm s2 (addr_of addr2 s2)) + | Bool.False -> (fun _ -> let s2 = add_ticks2 s1 in s2)) __)) __) + | ASM.ANL addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + (match l with + | Types.Inl l' -> + let { Types.fst = addr1; Types.snd = addr2 } = l' in + let and_val = + BitVector.conjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Direct, (Vector.VCons ((Nat.S Nat.O), ASM.Indirect, + (Vector.VCons (Nat.O, ASM.Data, Vector.VEmpty)))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Acc_a, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) and_val + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let and_val = + BitVector.conjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Direct, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) and_val) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let and_val = + Bool.andb (Status.get_cy_flag cm s0) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S Nat.O), + ASM.Bit_addr, (Vector.VCons (Nat.O, ASM.N_bit_addr, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr2) + Bool.True) + in + Status.set_flags cm s0 and_val Types.None + (Status.get_ov_flag cm s0))) + | ASM.ORL addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + (match l with + | Types.Inl l' -> + let { Types.fst = addr1; Types.snd = addr2 } = l' in + let or_val = + BitVector.inclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Data, (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Acc_a, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) or_val + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let or_val = + BitVector.inclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons (Nat.O, ASM.Direct, Vector.VEmpty)) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) or_val) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let or_val = + Bool.orb (Status.get_cy_flag cm s0) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S Nat.O), + ASM.Bit_addr, (Vector.VCons (Nat.O, ASM.N_bit_addr, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr2) + Bool.True) + in + Status.set_flags cm s0 or_val Types.None (Status.get_ov_flag cm s0))) + | ASM.XRL addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l' -> + let { Types.fst = addr1; Types.snd = addr2 } = l' in + let xor_val = + BitVector.exclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Registr, (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Acc_a, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) xor_val + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + let xor_val = + BitVector.exclusive_disjunction_bv (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr1)) + (Status.get_arg_8 cm s0 Bool.True + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Acc_a, (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Direct, Vector.VEmpty)) (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) xor_val)) + | ASM.CLR addr -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S + Nat.O), ASM.Carry, (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)))))) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ _ -> + let s0 = add_ticks1 s in + Status.set_arg_8 cm s0 ASM.ACC_A + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ _ -> + let s0 = add_ticks1 s in + Status.set_arg_1 cm s0 ASM.CARRY Bool.False) + | ASM.BIT_ADDR b -> + (fun _ _ -> + let s0 = add_ticks1 s in + Status.set_arg_1 cm s0 (ASM.BIT_ADDR b) Bool.False) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ __) + | ASM.CPL addr -> + (fun _ -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S + Nat.O), ASM.Carry, (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)))))) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> + (fun _ _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_acc = + BitVector.negation_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) old_acc + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_arg_1 cm s0 ASM.CARRY Bool.True in + let new_cy_flag = Bool.notb old_cy_flag in + Status.set_arg_1 cm s0 ASM.CARRY new_cy_flag) + | ASM.BIT_ADDR b -> + (fun _ _ -> + let s0 = add_ticks1 s in + let old_bit = Status.get_arg_1 cm s0 (ASM.BIT_ADDR b) Bool.True + in + let new_bit = Bool.notb old_bit in + Status.set_arg_1 cm s0 (ASM.BIT_ADDR b) new_bit) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ __) + | ASM.RL x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_acc = + Vector.rotate_left (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S Nat.O) old_acc + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc) + | ASM.RLC x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_cy_flag = + Vector.get_index' Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) old_acc + in + let new_acc = + Vector.shift_left (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S Nat.O) old_acc old_cy_flag + in + let s1 = Status.set_arg_1 cm s0 ASM.CARRY new_cy_flag in + Status.set_8051_sfr cm s1 Status.SFR_ACC_A new_acc) + | ASM.RR x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_acc = + Vector.rotate_right (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S Nat.O) old_acc + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc) + | ASM.RRC x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_cy_flag = Status.get_cy_flag cm s0 in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let new_cy_flag = + Vector.get_index' (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) Nat.O old_acc + in + let new_acc = + Vector.shift_right (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) (Nat.S Nat.O) old_acc old_cy_flag + in + let s1 = Status.set_arg_1 cm s0 ASM.CARRY new_cy_flag in + Status.set_8051_sfr cm s1 Status.SFR_ACC_A new_acc) + | ASM.SWAP x -> + (fun _ -> + let s0 = add_ticks1 s in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + (let { Types.fst = nu; Types.snd = nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) old_acc + in + (fun _ -> + let new_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) nl nu + in + Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc)) __) + | ASM.MOV addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + (match l with + | Types.Inl l' -> + (match l' with + | Types.Inl l'' -> + (match l'' with + | Types.Inl l''' -> + (match l''' with + | Types.Inl l'''' -> + let { Types.fst = addr1; Types.snd = addr2 } = l'''' in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Indirect, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) + addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons + ((Nat.S Nat.O), ASM.Indirect, (Vector.VCons + (Nat.O, ASM.Data, Vector.VEmpty)))))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Data, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) + | Types.Inr r'''' -> + let { Types.fst = addr1; Types.snd = addr2 } = r'''' in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Data, + Vector.VEmpty)))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2))) + | Types.Inr r''' -> + let { Types.fst = addr1; Types.snd = addr2 } = r''' in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + Nat.O (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (Vector.VCons (Nat.O, ASM.Direct, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Direct, (Vector.VCons + ((Nat.S Nat.O), ASM.Indirect, (Vector.VCons (Nat.O, + ASM.Data, Vector.VEmpty)))))))))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2))) + | Types.Inr r'' -> + let { Types.fst = addr1; Types.snd = addr2 } = r'' in + Status.set_arg_16 cm s0 + (Status.get_arg_16 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S Nat.O) (Vector.VCons (Nat.O, ASM.Data16, + Vector.VEmpty)) (Vector.VCons ((Nat.S Nat.O), + ASM.Data16, (Vector.VCons (Nat.O, ASM.Acc_dptr, + Vector.VEmpty)))) addr2)) addr1) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + Status.set_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S Nat.O) (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)) (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))) addr1) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Bit_addr, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), + ASM.N_bit_addr, (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)))))) addr2) Bool.False)) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + Status.set_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + Nat.O) (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)) + (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, (Vector.VCons + (Nat.O, ASM.Carry, Vector.VEmpty)))) addr1) + (Status.get_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S Nat.O)) (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), ASM.N_bit_addr, + (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))))) addr2) + Bool.False))) + | ASM.MOVX addr -> + (fun _ -> + let s0 = add_ticks1 s in + (match addr with + | Types.Inl l -> + let { Types.fst = addr1; Types.snd = addr2 } = l in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Acc_a, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S + Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))), ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S + Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2)) + | Types.Inr r -> + let { Types.fst = addr1; Types.snd = addr2 } = r in + Status.set_arg_8 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S Nat.O) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, Vector.VEmpty)))) (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))), ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))), ASM.Registr, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) addr1) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Acc_a, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)))) + | ASM.SETB b -> + (fun _ -> + let s0 = add_ticks1 s in + Status.set_arg_1 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S Nat.O) + (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), ASM.Carry, + (Vector.VCons (Nat.O, ASM.Bit_addr, Vector.VEmpty)))) + (Vector.VCons ((Nat.S Nat.O), ASM.Bit_addr, (Vector.VCons (Nat.O, + ASM.Carry, Vector.VEmpty)))) b) Bool.False) + | ASM.PUSH addr -> + (fun _ -> + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Direct, Vector.VEmpty)) addr with + | ASM.DIRECT d -> + (fun _ _ -> + let s0 = add_ticks1 s in + let new_sp = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + Status.write_at_stack_pointer cm s1 + (Status.get_arg_8 cm s1 Bool.False (ASM.DIRECT d))) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ __) + | ASM.POP addr -> + (fun _ -> + let s0 = add_ticks1 s in + let contents = Status.read_at_stack_pointer cm s0 in + (let { Types.fst = new_sp; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + (fun _ -> + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + Status.set_arg_8 cm s1 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Direct, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr) contents)) + __) + | ASM.XCH (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + let old_addr = + Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Registr, (Vector.VCons ((Nat.S Nat.O), ASM.Direct, + (Vector.VCons (Nat.O, ASM.Indirect, Vector.VEmpty)))))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))), + ASM.Indirect, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_pc, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))))))))) + addr2) + in + let old_acc = Status.get_8051_sfr cm s0 Status.SFR_ACC_A in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A old_addr in + Status.set_arg_8 cm s1 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Registr, (Vector.VCons + ((Nat.S Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr2) old_acc) + | ASM.XCHD (addr1, addr2) -> + (fun _ -> + let s0 = add_ticks1 s in + (let { Types.fst = acc_nu; Types.snd = acc_nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + in + (fun _ -> + (let { Types.fst = arg_nu; Types.snd = arg_nl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) + (Status.get_arg_8 cm s0 Bool.False + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (Vector.VCons (Nat.O, ASM.Indirect, + Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), ASM.Registr, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), + ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S (Nat.S + Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, + (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) addr2)) + in + (fun _ -> + let new_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) acc_nu arg_nl + in + let new_arg = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))) arg_nu acc_nl + in + let s1 = Status.set_8051_sfr cm s0 Status.SFR_ACC_A new_acc in + Status.set_arg_8 cm s1 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) (Vector.VCons + (Nat.O, ASM.Indirect, Vector.VEmpty)) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons + ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons (Nat.O, + ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) addr2) new_arg)) + __)) __) + | ASM.RET -> + (fun _ -> + let s0 = add_ticks1 s in + let high_bits = Status.read_at_stack_pointer cm s0 in + (let { Types.fst = new_sp; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + (fun _ -> + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + let low_bits = Status.read_at_stack_pointer cm s1 in + (let { Types.fst = new_sp0; Types.snd = flags0 } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s1 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + (fun _ -> + let s2 = Status.set_8051_sfr cm s1 Status.SFR_SP new_sp0 in + let new_pc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) high_bits low_bits + in + Status.set_program_counter cm s2 new_pc)) __)) __) + | ASM.RETI -> + (fun _ -> + let s0 = add_ticks1 s in + let high_bits = Status.read_at_stack_pointer cm s0 in + (let { Types.fst = new_sp; Types.snd = flags } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s0 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + (fun _ -> + let s1 = Status.set_8051_sfr cm s0 Status.SFR_SP new_sp in + let low_bits = Status.read_at_stack_pointer cm s1 in + (let { Types.fst = new_sp0; Types.snd = flags0 } = + Arithmetic.sub_8_with_carry + (Status.get_8051_sfr cm s1 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) Bool.False + in + (fun _ -> + let s2 = Status.set_8051_sfr cm s1 Status.SFR_SP new_sp0 in + let new_pc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) high_bits low_bits + in + Status.set_program_counter cm s2 new_pc)) __)) __) + | ASM.NOP -> (fun _ -> let s0 = add_ticks2 s in s0) + | ASM.JMP acc_dptr -> + (fun _ -> + let s0 = add_ticks1 s in + let jmp_addr = + Status.get_arg_16 cm s0 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode Nat.O (Nat.S + Nat.O) (Vector.VCons (Nat.O, ASM.Acc_dptr, Vector.VEmpty)) + (Vector.VCons ((Nat.S Nat.O), ASM.Data16, (Vector.VCons (Nat.O, + ASM.Acc_dptr, Vector.VEmpty)))) acc_dptr) + in + Status.set_program_counter cm s0 jmp_addr)) __ + +(** val compute_target_of_unconditional_jump : + BitVector.word -> ASM.instruction -> BitVector.word **) +let compute_target_of_unconditional_jump program_counter = function +| ASM.ACALL x -> + BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) +| ASM.LCALL x -> + BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) +| ASM.AJMP addr -> + Types.pi1 + ((match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Addr11, + Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 a -> + (fun _ -> + (let { Types.fst = pc_bu; Types.snd = pc_bl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))))) program_counter + in + (fun _ -> + let new_addr = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))))) pc_bu a + in + new_addr)) __) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.LJMP addr -> + Types.pi1 + ((match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Addr16, + Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 a -> (fun _ -> a)) __) +| ASM.SJMP addr -> + Types.pi1 + ((match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Relative, Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE r -> + (fun _ -> + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) program_counter + (Arithmetic.sign_extension r)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) +| ASM.MOVC (x, x0) -> + BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) +| ASM.RealInstruction x -> + BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + +(** val is_unconditional_jump : ASM.instruction -> Bool.bool **) +let is_unconditional_jump = function +| ASM.ACALL x -> Bool.False +| ASM.LCALL x -> Bool.False +| ASM.AJMP x -> Bool.True +| ASM.LJMP x -> Bool.True +| ASM.SJMP x -> Bool.True +| ASM.MOVC (x, x0) -> Bool.False +| ASM.RealInstruction x -> Bool.False + +(** val program_counter_after_other : + BitVector.word -> ASM.instruction -> BitVector.word **) +let program_counter_after_other program_counter instruction = + match is_unconditional_jump instruction with + | Bool.True -> + compute_target_of_unconditional_jump program_counter instruction + | Bool.False -> program_counter + +(** val addr_of_relative : + 'a1 -> ASM.subaddressing_mode -> 'a1 Status.preStatus -> BitVector.word **) +let addr_of_relative cm x s = + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Relative, + Vector.VEmpty)) x with + | ASM.DIRECT x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE r -> + (fun _ -> + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) s.Status.program_counter + (Arithmetic.sign_extension r)) + | ASM.ADDR11 x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x0 -> (fun _ -> assert false (* absurd case *))) __ + +(** val execute_1_0 : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + ((ASM.instruction, BitVector.word) Types.prod, Nat.nat) Types.prod -> + Status.status Types.sig0 **) +let execute_1_0 cm s0 instr_pc_ticks = + (let { Types.fst = instr_pc; Types.snd = ticks } = instr_pc_ticks in + (fun _ -> + (let { Types.fst = instr; Types.snd = pc } = { Types.fst = + instr_pc.Types.fst; Types.snd = instr_pc.Types.snd } + in + (fun _ -> + let s = Status.set_program_counter cm s0 pc in + (match instr with + | ASM.ACALL addr -> + (fun _ -> + let s1 = Status.set_clock cm s (Nat.plus ticks s.Status.clock) in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Addr11, Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 a -> + (fun _ -> + let new_sp = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s1 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s2 = Status.set_8051_sfr cm s1 Status.SFR_SP new_sp in + let { Types.fst = pc_bu; Types.snd = pc_bl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) s2.Status.program_counter + in + let s3 = Status.write_at_stack_pointer cm s2 pc_bl in + let new_sp0 = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s3 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s4 = Status.set_8051_sfr cm s3 Status.SFR_SP new_sp0 in + let s5 = Status.write_at_stack_pointer cm s4 pc_bu in + let { Types.fst = fiv; Types.snd = thr' } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) pc_bu + in + let new_addr = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))) fiv a + in + Status.set_program_counter cm s5 new_addr) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | ASM.LCALL addr -> + (fun _ -> + let s1 = Status.set_clock cm s (Nat.plus ticks s.Status.clock) in + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, + ASM.Addr16, Vector.VEmpty)) addr with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 a -> + (fun _ -> + let new_sp = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s1 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s2 = Status.set_8051_sfr cm s1 Status.SFR_SP new_sp in + let { Types.fst = pc_bu; Types.snd = pc_bl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) s2.Status.program_counter + in + let s3 = Status.write_at_stack_pointer cm s2 pc_bl in + let new_sp0 = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s3 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s4 = Status.set_8051_sfr cm s3 Status.SFR_SP new_sp0 in + let s5 = Status.write_at_stack_pointer cm s4 pc_bu in + Status.set_program_counter cm s5 a)) __) + | ASM.AJMP addr -> + (fun _ -> + let new_pc = + compute_target_of_unconditional_jump s.Status.program_counter instr + in + let s1 = Status.set_clock cm s (Nat.plus ticks s.Status.clock) in + Status.set_program_counter cm s1 new_pc) + | ASM.LJMP addr -> + (fun _ -> + let new_pc = + compute_target_of_unconditional_jump s.Status.program_counter instr + in + let s1 = Status.set_clock cm s (Nat.plus ticks s.Status.clock) in + Status.set_program_counter cm s1 new_pc) + | ASM.SJMP addr -> + (fun _ -> + let new_pc = + compute_target_of_unconditional_jump s.Status.program_counter instr + in + let s1 = Status.set_clock cm s (Nat.plus ticks s.Status.clock) in + Status.set_program_counter cm s1 new_pc) + | ASM.MOVC (addr1, addr2) -> + (fun _ -> + let s1 = Status.set_clock cm s (Nat.plus ticks s.Status.clock) in + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S + Nat.O), ASM.Acc_dptr, (Vector.VCons (Nat.O, ASM.Acc_pc, + Vector.VEmpty)))) addr2 with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> + (fun _ -> + let big_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) + (Status.get_8051_sfr cm s1 Status.SFR_ACC_A) + in + let dptr = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s1 Status.SFR_DPH) + (Status.get_8051_sfr cm s1 Status.SFR_DPL) + in + let new_addr = + Arithmetic.add + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) dptr big_acc + in + let result = + BitVectorTrie.lookup + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) new_addr cm + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) + in + Status.set_8051_sfr cm s1 Status.SFR_ACC_A result) + | ASM.ACC_PC -> + (fun _ -> + let big_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) + (Status.get_8051_sfr cm s1 Status.SFR_ACC_A) + in + let new_addr = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) s1.Status.program_counter + big_acc + in + let result = + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) new_addr cm + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) + in + Status.set_8051_sfr cm s1 Status.SFR_ACC_A result) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + | ASM.RealInstruction instr' -> + (fun _ -> + execute_1_preinstruction { Types.fst = ticks; Types.snd = ticks } cm + (addr_of_relative cm) instr' s)) __)) __)) __ + +(** val current_instruction_cost : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> Nat.nat **) +let current_instruction_cost cm s = + (Fetch.fetch cm s.Status.program_counter).Types.snd + +(** val execute_1' : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + Status.status Types.sig0 **) +let execute_1' cm s = + let instr_pc_ticks = Fetch.fetch cm s.Status.program_counter in + Types.pi1 (execute_1_0 cm s instr_pc_ticks) + +(** val execute_1 : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + Status.status **) +let execute_1 cm s = + Types.pi1 (execute_1' cm s) + +(** val execute_1_pseudo_instruction0 : + (Nat.nat, Nat.nat) Types.prod -> ASM.pseudo_assembly_program -> + (ASM.identifier -> BitVector.word) -> (ASM.identifier -> BitVector.word) + -> Status.pseudoStatus -> ASM.pseudo_instruction -> BitVector.word -> + Status.pseudoStatus **) +let execute_1_pseudo_instruction0 ticks cm addr_of_label addr_of_symbol s instr pc = + let s0 = Status.set_program_counter cm s pc in + let s1 = + match instr with + | ASM.Instruction instr0 -> + execute_1_preinstruction ticks cm (fun x y -> addr_of_label x) instr0 + s0 + | ASM.Comment cmt -> + Status.set_clock cm s0 (Nat.plus ticks.Types.fst s0.Status.clock) + | ASM.Cost cst -> s0 + | ASM.Jmp jmp -> + let s1 = + Status.set_clock cm s0 (Nat.plus ticks.Types.fst s0.Status.clock) + in + Status.set_program_counter cm s1 (addr_of_label jmp) + | ASM.Jnz (acc, dst1, dst2) -> + (match Bool.notb + (BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (Status.get_8051_sfr cm s0 Status.SFR_ACC_A) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))) with + | Bool.True -> + let s1 = + Status.set_clock cm s0 (Nat.plus ticks.Types.fst s0.Status.clock) + in + Status.set_program_counter cm s1 (addr_of_label dst1) + | Bool.False -> + let s1 = + Status.set_clock cm s0 (Nat.plus ticks.Types.snd s0.Status.clock) + in + Status.set_program_counter cm s1 (addr_of_label dst2)) + | ASM.Call call -> + let s1 = + Status.set_clock cm s0 (Nat.plus ticks.Types.fst s0.Status.clock) + in + let a = addr_of_label call in + let new_sp = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Status.get_8051_sfr cm s1 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s2 = Status.set_8051_sfr cm s1 Status.SFR_SP new_sp in + let { Types.fst = pc_bu; Types.snd = pc_bl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) s2.Status.program_counter + in + let s3 = Status.write_at_stack_pointer cm s2 pc_bl in + let new_sp0 = + Arithmetic.add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Status.get_8051_sfr cm s3 Status.SFR_SP) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S Nat.O)) + in + let s4 = Status.set_8051_sfr cm s3 Status.SFR_SP new_sp0 in + let s5 = Status.write_at_stack_pointer cm s4 pc_bu in + Status.set_program_counter cm s5 a + | ASM.Mov (dst, ident, off) -> + let s1 = + Status.set_clock cm s0 (Nat.plus ticks.Types.fst s0.Status.clock) + in + let v = + (Arithmetic.add_16_with_carry (addr_of_symbol ident) off Bool.False).Types.fst + in + (match dst with + | Types.Inl dptr -> Status.set_arg_16 cm s1 v dptr + | Types.Inr pr -> + let v' = + match pr.Types.snd with + | ASM.HIGH -> + (Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) v).Types.fst + | ASM.LOW -> + (Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) v).Types.snd + in + Status.set_arg_8 cm s1 + (ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S + Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons + ((Nat.S Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Registr, + Vector.VEmpty)))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, + (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), + ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_b, + (Vector.VCons ((Nat.S Nat.O), ASM.Ext_indirect, (Vector.VCons + (Nat.O, ASM.Ext_indirect_dptr, Vector.VEmpty)))))))))))))) + pr.Types.fst) v') + in + s1 + +(** val execute_1_pseudo_instruction : + ASM.pseudo_assembly_program -> (BitVector.word -> __ -> (Nat.nat, + Nat.nat) Types.prod) -> (ASM.identifier -> BitVector.word) -> + (ASM.identifier -> BitVector.word) -> Status.pseudoStatus -> + Status.pseudoStatus **) +let execute_1_pseudo_instruction cm ticks_of addr_of_label addr_of_symbol s = + let { Types.fst = instr; Types.snd = pc } = + ASM.fetch_pseudo_instruction cm.ASM.code s.Status.program_counter + in + let ticks = ticks_of s.Status.program_counter __ in + execute_1_pseudo_instruction0 ticks cm addr_of_label addr_of_symbol s instr + pc + +(** val execute : + Nat.nat -> BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + Status.status **) +let rec execute n cm s = + match n with + | Nat.O -> s + | Nat.S o -> execute o cm (execute_1 cm s) + diff --git a/extracted/interpret.mli b/extracted/interpret.mli new file mode 100644 index 0000000..5155fc6 --- /dev/null +++ b/extracted/interpret.mli @@ -0,0 +1,166 @@ +open Preamble + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +val execute_1_preinstruction : + (Nat.nat, Nat.nat) Types.prod -> 'a2 -> ('a1 -> 'a2 Status.preStatus -> + BitVector.word) -> 'a1 ASM.preinstruction -> 'a2 Status.preStatus -> 'a2 + Status.preStatus + +val execute_1_preinstruction_ok' : + (Nat.nat, Nat.nat) Types.prod -> 'a2 -> ('a1 -> 'a2 Status.preStatus -> + BitVector.word) -> 'a1 ASM.preinstruction -> 'a2 Status.preStatus -> 'a2 + Status.preStatus Types.sig0 + +val compute_target_of_unconditional_jump : + BitVector.word -> ASM.instruction -> BitVector.word + +val is_unconditional_jump : ASM.instruction -> Bool.bool + +val program_counter_after_other : + BitVector.word -> ASM.instruction -> BitVector.word + +val addr_of_relative : + 'a1 -> ASM.subaddressing_mode -> 'a1 Status.preStatus -> BitVector.word + +val execute_1_0 : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + ((ASM.instruction, BitVector.word) Types.prod, Nat.nat) Types.prod -> + Status.status Types.sig0 + +val current_instruction_cost : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> Nat.nat + +val execute_1' : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + Status.status Types.sig0 + +val execute_1 : + BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + Status.status + +val execute_1_pseudo_instruction0 : + (Nat.nat, Nat.nat) Types.prod -> ASM.pseudo_assembly_program -> + (ASM.identifier -> BitVector.word) -> (ASM.identifier -> BitVector.word) -> + Status.pseudoStatus -> ASM.pseudo_instruction -> BitVector.word -> + Status.pseudoStatus + +val execute_1_pseudo_instruction : + ASM.pseudo_assembly_program -> (BitVector.word -> __ -> (Nat.nat, Nat.nat) + Types.prod) -> (ASM.identifier -> BitVector.word) -> (ASM.identifier -> + BitVector.word) -> Status.pseudoStatus -> Status.pseudoStatus + +val execute : + Nat.nat -> BitVector.byte BitVectorTrie.bitVectorTrie -> Status.status -> + Status.status + diff --git a/extracted/interpret2.ml b/extracted/interpret2.ml new file mode 100644 index 0000000..530ad61 --- /dev/null +++ b/extracted/interpret2.ml @@ -0,0 +1,469 @@ +open Preamble + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Interpret + +open ASMCosts + +open Stacksize + +open SmallstepExec + +open Executions + +open Measurable + +(** val mk_trans_system_of_abstract_status : + StructuredTraces.abstract_status -> (__ -> __ Monad.max_def__o__monad) -> + (IO.io_out, IO.io_in) SmallstepExec.trans_system **) +let mk_trans_system_of_abstract_status s as_eval = + { SmallstepExec.is_final = (fun x -> s.StructuredTraces.as_result); + SmallstepExec.step = (fun x status -> + let tr = + match StructuredTraces.as_label s status with + | Types.None -> Events.e0 + | Types.Some cst -> Events.echarge cst + in + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) (as_eval status) + (fun status' -> + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { Types.fst = tr; + Types.snd = status' }))) } + +(** val mk_fullexec_of_abstract_status : + StructuredTraces.abstract_status -> (__ -> __ Monad.max_def__o__monad) -> + __ -> (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let mk_fullexec_of_abstract_status s as_eval as_init = + { SmallstepExec.es1 = (mk_trans_system_of_abstract_status s as_eval); + SmallstepExec.make_global = (fun x -> Obj.magic Types.It); + SmallstepExec.make_initial_state = (fun x -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) as_init)) } + +(** val mk_preclassified_system_of_abstract_status : + StructuredTraces.abstract_status -> (__ -> __ Monad.max_def__o__monad) -> + __ -> Measurable.preclassified_system **) +let mk_preclassified_system_of_abstract_status s as_eval as_init = + { Measurable.pcs_exec = (mk_fullexec_of_abstract_status s as_eval as_init); + Measurable.pcs_labelled = (fun x st -> + Bool.notb (PositiveMap.is_none (StructuredTraces.as_label s st))); + Measurable.pcs_classify = (fun x -> s.StructuredTraces.as_classify); + Measurable.pcs_callee = (fun x st _ -> + s.StructuredTraces.as_call_ident st) } + +(** val oC_preclassified_system : + ASM.labelled_object_code -> Measurable.preclassified_system **) +let oC_preclassified_system c = + mk_preclassified_system_of_abstract_status (ASMCosts.oC_abstract_status c) + (fun st -> + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) + (Interpret.execute_1 c.ASM.cm (Obj.magic st))) + (Obj.magic (Status.initialise_status c.ASM.cm)) + +open Assembly + +(** val execute_1_pseudo_instruction' : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) + -> (BitVector.word -> Bool.bool) -> Status.pseudoStatus -> + Status.pseudoStatus **) +let execute_1_pseudo_instruction' cm addr_of_label addr_of_symbol sigma policy status = + Interpret.execute_1_pseudo_instruction cm (fun x _ -> + Assembly.ticks_of cm addr_of_label sigma policy x) addr_of_label + addr_of_symbol status + +(** val classify_pseudo_instruction : + ASM.pseudo_instruction -> StructuredTraces.status_class **) +let classify_pseudo_instruction = function +| ASM.Instruction pre -> AbstractStatus.aSM_classify00 pre +| ASM.Comment x -> StructuredTraces.Cl_other +| ASM.Cost x -> StructuredTraces.Cl_other +| ASM.Jmp x -> StructuredTraces.Cl_other +| ASM.Jnz (x, x0, x1) -> StructuredTraces.Cl_jump +| ASM.Call x -> StructuredTraces.Cl_call +| ASM.Mov (x, x0, x1) -> StructuredTraces.Cl_other + +(** val aSM_classify : + ASM.pseudo_assembly_program -> Status.pseudoStatus -> + StructuredTraces.status_class **) +let aSM_classify cm s = + classify_pseudo_instruction + (ASM.fetch_pseudo_instruction cm.ASM.code s.Status.program_counter).Types.fst + +(** val aSM_as_label_of_pc : + ASM.pseudo_assembly_program -> BitVector.word -> CostLabel.costlabel + Types.option **) +let aSM_as_label_of_pc prog pc = + match (ASM.fetch_pseudo_instruction prog.ASM.code pc).Types.fst with + | ASM.Instruction x -> Types.None + | ASM.Comment x -> Types.None + | ASM.Cost label -> Types.Some label + | ASM.Jmp x -> Types.None + | ASM.Jnz (x, x0, x1) -> Types.None + | ASM.Call x -> Types.None + | ASM.Mov (x, x0, x1) -> Types.None + +(** val aSM_as_result : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + Status.pseudoStatus -> Integers.int Types.option **) +let aSM_as_result prog addr_of_labels st = + let finaladdr = addr_of_labels prog.ASM.final_label in + ASMCosts.as_result_of_finaladdr prog st finaladdr + +open AssocList + +(** val aSM_as_call_ident : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) + -> (BitVector.word -> Bool.bool) -> Status.pseudoStatus Types.sig0 -> + AST.ident **) +let aSM_as_call_ident prog addr_of_label addr_of_symbol sigma policy s0 = + let st = + execute_1_pseudo_instruction' prog addr_of_label addr_of_symbol sigma + policy (Types.pi1 s0) + in + let { Types.fst = lbl; Types.snd = instr } = + Util.nth_safe + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) st.Status.program_counter) prog.ASM.code + in + (match lbl with + | Types.None -> assert false (* absurd case *) + | Types.Some lbl' -> + (match AssocList.assoc_list_lookup lbl' + (Identifiers.eq_identifier PreIdentifiers.ASMTag) + prog.ASM.renamed_symbols with + | Types.None -> assert false (* absurd case *) + | Types.Some id -> id)) + +(** val aSM_abstract_status : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) + -> (BitVector.word -> Bool.bool) -> StructuredTraces.abstract_status **) +let aSM_abstract_status prog addr_of_label addr_of_symbol sigma policy = + { StructuredTraces.as_pc = AbstractStatus.word_deqset; + StructuredTraces.as_pc_of = (Obj.magic (Status.program_counter prog)); + StructuredTraces.as_classify = (Obj.magic (aSM_classify prog)); + StructuredTraces.as_label_of_pc = (Obj.magic (aSM_as_label_of_pc prog)); + StructuredTraces.as_result = + (Obj.magic (aSM_as_result prog addr_of_label)); + StructuredTraces.as_call_ident = + (Obj.magic + (aSM_as_call_ident prog addr_of_label addr_of_symbol sigma policy)); + StructuredTraces.as_tailcall_ident = (fun clearme -> + let st = clearme in + (match (ASM.fetch_pseudo_instruction prog.ASM.code + (Obj.magic st).Status.program_counter).Types.fst with + | ASM.Instruction clearme0 -> + (match clearme0 with + | ASM.ADD (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.ADDC (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.SUBB (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.INC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.DEC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.MUL (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.DIV (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.DA x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.JC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JNC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JB (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JNB (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JBC (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JZ x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.JNZ x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.CJNE (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.DJNZ (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.ANL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.ORL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.XRL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.CLR x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.CPL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RL x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RLC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RR x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RRC x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.SWAP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.MOV x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.MOVX x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.SETB x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.PUSH x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.POP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.XCH (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.XCHD (x, y) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.RET -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_return StructuredTraces.Cl_tailcall __) + | ASM.RETI -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_return StructuredTraces.Cl_tailcall __) + | ASM.NOP -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.JMP x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_call StructuredTraces.Cl_tailcall __)) + | ASM.Comment x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.Cost x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.Jmp x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __) + | ASM.Jnz (x, y, abs) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_jump StructuredTraces.Cl_tailcall __) + | ASM.Call x -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_call StructuredTraces.Cl_tailcall __) + | ASM.Mov (x, y, abs) -> + (fun _ -> + Obj.magic StructuredTraces.status_class_discr + StructuredTraces.Cl_other StructuredTraces.Cl_tailcall __)) __) } + +(** val aSM_preclassified_system : + ASM.pseudo_assembly_program -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> Measurable.preclassified_system **) +let aSM_preclassified_system c sigma policy = + let label_map = (Fetch.create_label_cost_map c.ASM.code).Types.fst in + let symbol_map = Status.construct_datalabels c.ASM.preamble in + let addr_of_label = fun x -> + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (Identifiers.lookup_def PreIdentifiers.ASMTag label_map x Nat.O) + in + let addr_of_symbol = fun x -> + Identifiers.lookup_def PreIdentifiers.ASMTag symbol_map x + (addr_of_label x) + in + mk_preclassified_system_of_abstract_status + (aSM_abstract_status c addr_of_label addr_of_symbol sigma policy) + (fun st -> + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) + (execute_1_pseudo_instruction' c addr_of_label addr_of_symbol sigma + policy (Obj.magic st))) (Obj.magic (Status.initialise_status c)) + diff --git a/extracted/interpret2.mli b/extracted/interpret2.mli new file mode 100644 index 0000000..2858287 --- /dev/null +++ b/extracted/interpret2.mli @@ -0,0 +1,180 @@ +open Preamble + +open Fetch + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open StructuredTraces + +open AbstractStatus + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + +open StatusProofs + +open Interpret + +open ASMCosts + +open Stacksize + +open SmallstepExec + +open Executions + +open Measurable + +val mk_trans_system_of_abstract_status : + StructuredTraces.abstract_status -> (__ -> __ Monad.max_def__o__monad) -> + (IO.io_out, IO.io_in) SmallstepExec.trans_system + +val mk_fullexec_of_abstract_status : + StructuredTraces.abstract_status -> (__ -> __ Monad.max_def__o__monad) -> + __ -> (IO.io_out, IO.io_in) SmallstepExec.fullexec + +val mk_preclassified_system_of_abstract_status : + StructuredTraces.abstract_status -> (__ -> __ Monad.max_def__o__monad) -> + __ -> Measurable.preclassified_system + +val oC_preclassified_system : + ASM.labelled_object_code -> Measurable.preclassified_system + +open Assembly + +val execute_1_pseudo_instruction' : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> Status.pseudoStatus -> Status.pseudoStatus + +val classify_pseudo_instruction : + ASM.pseudo_instruction -> StructuredTraces.status_class + +val aSM_classify : + ASM.pseudo_assembly_program -> Status.pseudoStatus -> + StructuredTraces.status_class + +val aSM_as_label_of_pc : + ASM.pseudo_assembly_program -> BitVector.word -> CostLabel.costlabel + Types.option + +val aSM_as_result : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + Status.pseudoStatus -> Integers.int Types.option + +open AssocList + +val aSM_as_call_ident : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> Status.pseudoStatus Types.sig0 -> + AST.ident + +val aSM_abstract_status : + ASM.pseudo_assembly_program -> (ASM.identifier -> BitVector.word) -> + (ASM.identifier -> BitVector.word) -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> StructuredTraces.abstract_status + +val aSM_preclassified_system : + ASM.pseudo_assembly_program -> (BitVector.word -> BitVector.word) -> + (BitVector.word -> Bool.bool) -> Measurable.preclassified_system + diff --git a/extracted/jmeq.ml b/extracted/jmeq.ml new file mode 100644 index 0000000..91d5097 --- /dev/null +++ b/extracted/jmeq.ml @@ -0,0 +1,132 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +type sigma = + __ + (* singleton inductive, whose constructor was mk_Sigma *) + +(** val sigma_rect_Type4 : (__ -> __ -> 'a1) -> sigma -> 'a1 **) +let rec sigma_rect_Type4 h_mk_Sigma x_812 = + let x_813 = x_812 in h_mk_Sigma __ x_813 + +(** val sigma_rect_Type5 : (__ -> __ -> 'a1) -> sigma -> 'a1 **) +let rec sigma_rect_Type5 h_mk_Sigma x_815 = + let x_816 = x_815 in h_mk_Sigma __ x_816 + +(** val sigma_rect_Type3 : (__ -> __ -> 'a1) -> sigma -> 'a1 **) +let rec sigma_rect_Type3 h_mk_Sigma x_818 = + let x_819 = x_818 in h_mk_Sigma __ x_819 + +(** val sigma_rect_Type2 : (__ -> __ -> 'a1) -> sigma -> 'a1 **) +let rec sigma_rect_Type2 h_mk_Sigma x_821 = + let x_822 = x_821 in h_mk_Sigma __ x_822 + +(** val sigma_rect_Type1 : (__ -> __ -> 'a1) -> sigma -> 'a1 **) +let rec sigma_rect_Type1 h_mk_Sigma x_824 = + let x_825 = x_824 in h_mk_Sigma __ x_825 + +(** val sigma_rect_Type0 : (__ -> __ -> 'a1) -> sigma -> 'a1 **) +let rec sigma_rect_Type0 h_mk_Sigma x_827 = + let x_828 = x_827 in h_mk_Sigma __ x_828 + +(** val sigma_inv_rect_Type4 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let sigma_inv_rect_Type4 hterm h1 = + let hcut = sigma_rect_Type4 h1 hterm in hcut __ + +(** val sigma_inv_rect_Type3 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let sigma_inv_rect_Type3 hterm h1 = + let hcut = sigma_rect_Type3 h1 hterm in hcut __ + +(** val sigma_inv_rect_Type2 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let sigma_inv_rect_Type2 hterm h1 = + let hcut = sigma_rect_Type2 h1 hterm in hcut __ + +(** val sigma_inv_rect_Type1 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let sigma_inv_rect_Type1 hterm h1 = + let hcut = sigma_rect_Type1 h1 hterm in hcut __ + +(** val sigma_inv_rect_Type0 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let sigma_inv_rect_Type0 hterm h1 = + let hcut = sigma_rect_Type0 h1 hterm in hcut __ + +type p1 = __ + +(** val p2 : sigma -> p1 **) +let p2 s = + let x = s in x + +(** val jmeq_rect_Type4 : 'a1 -> 'a2 -> 'a3 -> 'a2 **) +let rec jmeq_rect_Type4 x h_refl_jmeq x_851 = + h_refl_jmeq + +(** val jmeq_rect_Type5 : 'a1 -> 'a2 -> 'a3 -> 'a2 **) +let rec jmeq_rect_Type5 x h_refl_jmeq x_854 = + h_refl_jmeq + +(** val jmeq_rect_Type3 : 'a1 -> 'a2 -> 'a3 -> 'a2 **) +let rec jmeq_rect_Type3 x h_refl_jmeq x_857 = + h_refl_jmeq + +(** val jmeq_rect_Type2 : 'a1 -> 'a2 -> 'a3 -> 'a2 **) +let rec jmeq_rect_Type2 x h_refl_jmeq x_860 = + h_refl_jmeq + +(** val jmeq_rect_Type1 : 'a1 -> 'a2 -> 'a3 -> 'a2 **) +let rec jmeq_rect_Type1 x h_refl_jmeq x_863 = + h_refl_jmeq + +(** val jmeq_rect_Type0 : 'a1 -> 'a2 -> 'a3 -> 'a2 **) +let rec jmeq_rect_Type0 x h_refl_jmeq x_866 = + h_refl_jmeq + +(** val jmeq_inv_rect_Type4 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 **) +let jmeq_inv_rect_Type4 x2 x4 h1 = + let hcut = jmeq_rect_Type4 x2 h1 x4 in hcut __ __ + +(** val jmeq_inv_rect_Type3 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 **) +let jmeq_inv_rect_Type3 x2 x4 h1 = + let hcut = jmeq_rect_Type3 x2 h1 x4 in hcut __ __ + +(** val jmeq_inv_rect_Type2 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 **) +let jmeq_inv_rect_Type2 x2 x4 h1 = + let hcut = jmeq_rect_Type2 x2 h1 x4 in hcut __ __ + +(** val jmeq_inv_rect_Type1 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 **) +let jmeq_inv_rect_Type1 x2 x4 h1 = + let hcut = jmeq_rect_Type1 x2 h1 x4 in hcut __ __ + +(** val jmeq_inv_rect_Type0 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 **) +let jmeq_inv_rect_Type0 x2 x4 h1 = + let hcut = jmeq_rect_Type0 x2 h1 x4 in hcut __ __ + +(** val jmeq_discr : 'a1 -> 'a2 -> __ **) +let jmeq_discr a2 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH)) __ + +(** val cast : 'a1 -> 'a2 **) +let cast x = + (fun x0 -> Obj.magic x0) x + +type ('a, 'x) curry = 'x + +(** val g : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let g x h y = + (fun _ -> Logic.eq_rect_Type0 __ h __) __ + +type 'p pP = 'p + +(** val e : 'a1 -> 'a2 pP -> 'a1 -> 'a2 pP **) +let e a h b = + let x = g a h b in x + +(** val jmeq_elim : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let jmeq_elim x x0 y = + e x x0 y + diff --git a/extracted/jmeq.mli b/extracted/jmeq.mli new file mode 100644 index 0000000..a431bf6 --- /dev/null +++ b/extracted/jmeq.mli @@ -0,0 +1,76 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +type sigma = + __ + (* singleton inductive, whose constructor was mk_Sigma *) + +val sigma_rect_Type4 : (__ -> __ -> 'a1) -> sigma -> 'a1 + +val sigma_rect_Type5 : (__ -> __ -> 'a1) -> sigma -> 'a1 + +val sigma_rect_Type3 : (__ -> __ -> 'a1) -> sigma -> 'a1 + +val sigma_rect_Type2 : (__ -> __ -> 'a1) -> sigma -> 'a1 + +val sigma_rect_Type1 : (__ -> __ -> 'a1) -> sigma -> 'a1 + +val sigma_rect_Type0 : (__ -> __ -> 'a1) -> sigma -> 'a1 + +val sigma_inv_rect_Type4 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val sigma_inv_rect_Type3 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val sigma_inv_rect_Type2 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val sigma_inv_rect_Type1 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val sigma_inv_rect_Type0 : sigma -> (__ -> __ -> __ -> 'a1) -> 'a1 + +type p1 = __ + +val p2 : sigma -> p1 + +val jmeq_rect_Type4 : 'a1 -> 'a2 -> 'a3 -> 'a2 + +val jmeq_rect_Type5 : 'a1 -> 'a2 -> 'a3 -> 'a2 + +val jmeq_rect_Type3 : 'a1 -> 'a2 -> 'a3 -> 'a2 + +val jmeq_rect_Type2 : 'a1 -> 'a2 -> 'a3 -> 'a2 + +val jmeq_rect_Type1 : 'a1 -> 'a2 -> 'a3 -> 'a2 + +val jmeq_rect_Type0 : 'a1 -> 'a2 -> 'a3 -> 'a2 + +val jmeq_inv_rect_Type4 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 + +val jmeq_inv_rect_Type3 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 + +val jmeq_inv_rect_Type2 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 + +val jmeq_inv_rect_Type1 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 + +val jmeq_inv_rect_Type0 : 'a1 -> 'a2 -> (__ -> __ -> 'a3) -> 'a3 + +val jmeq_discr : 'a1 -> 'a2 -> __ + +val cast : 'a1 -> 'a2 + +type ('a, 'x) curry = 'x + +val g : 'a1 -> 'a2 -> 'a1 -> 'a2 + +type 'p pP = 'p + +val e : 'a1 -> 'a2 pP -> 'a1 -> 'a2 pP + +val jmeq_elim : 'a1 -> 'a2 -> 'a1 -> 'a2 + diff --git a/extracted/joint.ml b/extracted/joint.ml new file mode 100644 index 0000000..c92b178 --- /dev/null +++ b/extracted/joint.ml @@ -0,0 +1,2740 @@ +open Preamble + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open CostLabel + +open Order + +open Registers + +open I8051 + +open BitVectorTrie + +open Graphs + +open LabelledObjects + +open Sets + +open Listb + +open String + +type 't argument = +| Reg of 't +| Imm of BitVector.byte + +(** val argument_rect_Type4 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 **) +let rec argument_rect_Type4 h_Reg h_Imm = function +| Reg x_16867 -> h_Reg x_16867 +| Imm x_16868 -> h_Imm x_16868 + +(** val argument_rect_Type5 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 **) +let rec argument_rect_Type5 h_Reg h_Imm = function +| Reg x_16872 -> h_Reg x_16872 +| Imm x_16873 -> h_Imm x_16873 + +(** val argument_rect_Type3 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 **) +let rec argument_rect_Type3 h_Reg h_Imm = function +| Reg x_16877 -> h_Reg x_16877 +| Imm x_16878 -> h_Imm x_16878 + +(** val argument_rect_Type2 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 **) +let rec argument_rect_Type2 h_Reg h_Imm = function +| Reg x_16882 -> h_Reg x_16882 +| Imm x_16883 -> h_Imm x_16883 + +(** val argument_rect_Type1 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 **) +let rec argument_rect_Type1 h_Reg h_Imm = function +| Reg x_16887 -> h_Reg x_16887 +| Imm x_16888 -> h_Imm x_16888 + +(** val argument_rect_Type0 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 **) +let rec argument_rect_Type0 h_Reg h_Imm = function +| Reg x_16892 -> h_Reg x_16892 +| Imm x_16893 -> h_Imm x_16893 + +(** val argument_inv_rect_Type4 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> + 'a2 **) +let argument_inv_rect_Type4 hterm h1 h2 = + let hcut = argument_rect_Type4 h1 h2 hterm in hcut __ + +(** val argument_inv_rect_Type3 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> + 'a2 **) +let argument_inv_rect_Type3 hterm h1 h2 = + let hcut = argument_rect_Type3 h1 h2 hterm in hcut __ + +(** val argument_inv_rect_Type2 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> + 'a2 **) +let argument_inv_rect_Type2 hterm h1 h2 = + let hcut = argument_rect_Type2 h1 h2 hterm in hcut __ + +(** val argument_inv_rect_Type1 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> + 'a2 **) +let argument_inv_rect_Type1 hterm h1 h2 = + let hcut = argument_rect_Type1 h1 h2 hterm in hcut __ + +(** val argument_inv_rect_Type0 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> + 'a2 **) +let argument_inv_rect_Type0 hterm h1 h2 = + let hcut = argument_rect_Type0 h1 h2 hterm in hcut __ + +(** val argument_discr : 'a1 argument -> 'a1 argument -> __ **) +let argument_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Reg a0 -> Obj.magic (fun _ dH -> dH __) + | Imm a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val argument_jmdiscr : 'a1 argument -> 'a1 argument -> __ **) +let argument_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Reg a0 -> Obj.magic (fun _ dH -> dH __) + | Imm a0 -> Obj.magic (fun _ dH -> dH __)) y + +type psd_argument = Registers.register argument + +(** val psd_argument_from_reg : Registers.register -> psd_argument **) +let psd_argument_from_reg x = + Reg x + +(** val dpi1__o__reg_to_psd_argument__o__inject : + (Registers.register, 'a1) Types.dPair -> psd_argument Types.sig0 **) +let dpi1__o__reg_to_psd_argument__o__inject x2 = + psd_argument_from_reg x2.Types.dpi1 + +(** val eject__o__reg_to_psd_argument__o__inject : + Registers.register Types.sig0 -> psd_argument Types.sig0 **) +let eject__o__reg_to_psd_argument__o__inject x2 = + psd_argument_from_reg (Types.pi1 x2) + +(** val reg_to_psd_argument__o__inject : + Registers.register -> psd_argument Types.sig0 **) +let reg_to_psd_argument__o__inject x1 = + psd_argument_from_reg x1 + +(** val dpi1__o__reg_to_psd_argument : + (Registers.register, 'a1) Types.dPair -> psd_argument **) +let dpi1__o__reg_to_psd_argument x1 = + psd_argument_from_reg x1.Types.dpi1 + +(** val eject__o__reg_to_psd_argument : + Registers.register Types.sig0 -> psd_argument **) +let eject__o__reg_to_psd_argument x1 = + psd_argument_from_reg (Types.pi1 x1) + +(** val psd_argument_from_byte : BitVector.byte -> psd_argument **) +let psd_argument_from_byte x = + Imm x + +(** val dpi1__o__byte_to_psd_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> psd_argument Types.sig0 **) +let dpi1__o__byte_to_psd_argument__o__inject x2 = + psd_argument_from_byte x2.Types.dpi1 + +(** val eject__o__byte_to_psd_argument__o__inject : + BitVector.byte Types.sig0 -> psd_argument Types.sig0 **) +let eject__o__byte_to_psd_argument__o__inject x2 = + psd_argument_from_byte (Types.pi1 x2) + +(** val byte_to_psd_argument__o__inject : + BitVector.byte -> psd_argument Types.sig0 **) +let byte_to_psd_argument__o__inject x1 = + psd_argument_from_byte x1 + +(** val dpi1__o__byte_to_psd_argument : + (BitVector.byte, 'a1) Types.dPair -> psd_argument **) +let dpi1__o__byte_to_psd_argument x1 = + psd_argument_from_byte x1.Types.dpi1 + +(** val eject__o__byte_to_psd_argument : + BitVector.byte Types.sig0 -> psd_argument **) +let eject__o__byte_to_psd_argument x1 = + psd_argument_from_byte (Types.pi1 x1) + +type hdw_argument = I8051.register argument + +(** val hdw_argument_from_reg : I8051.register -> hdw_argument **) +let hdw_argument_from_reg x = + Reg x + +(** val dpi1__o__reg_to_hdw_argument__o__inject : + (I8051.register, 'a1) Types.dPair -> hdw_argument Types.sig0 **) +let dpi1__o__reg_to_hdw_argument__o__inject x2 = + hdw_argument_from_reg x2.Types.dpi1 + +(** val eject__o__reg_to_hdw_argument__o__inject : + I8051.register Types.sig0 -> hdw_argument Types.sig0 **) +let eject__o__reg_to_hdw_argument__o__inject x2 = + hdw_argument_from_reg (Types.pi1 x2) + +(** val reg_to_hdw_argument__o__inject : + I8051.register -> hdw_argument Types.sig0 **) +let reg_to_hdw_argument__o__inject x1 = + hdw_argument_from_reg x1 + +(** val dpi1__o__reg_to_hdw_argument : + (I8051.register, 'a1) Types.dPair -> hdw_argument **) +let dpi1__o__reg_to_hdw_argument x1 = + hdw_argument_from_reg x1.Types.dpi1 + +(** val eject__o__reg_to_hdw_argument : + I8051.register Types.sig0 -> hdw_argument **) +let eject__o__reg_to_hdw_argument x1 = + hdw_argument_from_reg (Types.pi1 x1) + +(** val hdw_argument_from_byte : BitVector.byte -> hdw_argument **) +let hdw_argument_from_byte x = + Imm x + +(** val dpi1__o__byte_to_hdw_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> psd_argument Types.sig0 **) +let dpi1__o__byte_to_hdw_argument__o__inject x2 = + psd_argument_from_byte x2.Types.dpi1 + +(** val eject__o__byte_to_hdw_argument__o__inject : + BitVector.byte Types.sig0 -> psd_argument Types.sig0 **) +let eject__o__byte_to_hdw_argument__o__inject x2 = + psd_argument_from_byte (Types.pi1 x2) + +(** val byte_to_hdw_argument__o__inject : + BitVector.byte -> psd_argument Types.sig0 **) +let byte_to_hdw_argument__o__inject x1 = + psd_argument_from_byte x1 + +(** val dpi1__o__byte_to_hdw_argument : + (BitVector.byte, 'a1) Types.dPair -> psd_argument **) +let dpi1__o__byte_to_hdw_argument x1 = + psd_argument_from_byte x1.Types.dpi1 + +(** val eject__o__byte_to_hdw_argument : + BitVector.byte Types.sig0 -> psd_argument **) +let eject__o__byte_to_hdw_argument x1 = + psd_argument_from_byte (Types.pi1 x1) + +(** val byte_of_nat : Nat.nat -> BitVector.byte **) +let byte_of_nat = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + +(** val zero_byte : BitVector.byte **) +let zero_byte = + BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) + +type unserialized_params = { ext_seq_labels : (__ -> Graphs.label List.list); + has_tailcalls : Bool.bool } + +(** val unserialized_params_rect_Type4 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 **) +let rec unserialized_params_rect_Type4 h_mk_unserialized_params x_16928 = + let { ext_seq_labels = ext_seq_labels0; has_tailcalls = has_tailcalls0 } = + x_16928 + in + h_mk_unserialized_params __ __ __ __ __ __ __ __ __ __ __ __ __ + ext_seq_labels0 has_tailcalls0 __ + +(** val unserialized_params_rect_Type5 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 **) +let rec unserialized_params_rect_Type5 h_mk_unserialized_params x_16930 = + let { ext_seq_labels = ext_seq_labels0; has_tailcalls = has_tailcalls0 } = + x_16930 + in + h_mk_unserialized_params __ __ __ __ __ __ __ __ __ __ __ __ __ + ext_seq_labels0 has_tailcalls0 __ + +(** val unserialized_params_rect_Type3 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 **) +let rec unserialized_params_rect_Type3 h_mk_unserialized_params x_16932 = + let { ext_seq_labels = ext_seq_labels0; has_tailcalls = has_tailcalls0 } = + x_16932 + in + h_mk_unserialized_params __ __ __ __ __ __ __ __ __ __ __ __ __ + ext_seq_labels0 has_tailcalls0 __ + +(** val unserialized_params_rect_Type2 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 **) +let rec unserialized_params_rect_Type2 h_mk_unserialized_params x_16934 = + let { ext_seq_labels = ext_seq_labels0; has_tailcalls = has_tailcalls0 } = + x_16934 + in + h_mk_unserialized_params __ __ __ __ __ __ __ __ __ __ __ __ __ + ext_seq_labels0 has_tailcalls0 __ + +(** val unserialized_params_rect_Type1 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 **) +let rec unserialized_params_rect_Type1 h_mk_unserialized_params x_16936 = + let { ext_seq_labels = ext_seq_labels0; has_tailcalls = has_tailcalls0 } = + x_16936 + in + h_mk_unserialized_params __ __ __ __ __ __ __ __ __ __ __ __ __ + ext_seq_labels0 has_tailcalls0 __ + +(** val unserialized_params_rect_Type0 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 **) +let rec unserialized_params_rect_Type0 h_mk_unserialized_params x_16938 = + let { ext_seq_labels = ext_seq_labels0; has_tailcalls = has_tailcalls0 } = + x_16938 + in + h_mk_unserialized_params __ __ __ __ __ __ __ __ __ __ __ __ __ + ext_seq_labels0 has_tailcalls0 __ + +type acc_a_reg = __ + +type acc_b_reg = __ + +type acc_a_arg = __ + +type acc_b_arg = __ + +type dpl_reg = __ + +type dph_reg = __ + +type dpl_arg = __ + +type dph_arg = __ + +type snd_arg = __ + +type pair_move = __ + +type call_args = __ + +type call_dest = __ + +type ext_seq = __ + +(** val ext_seq_labels : + unserialized_params -> __ -> Graphs.label List.list **) +let rec ext_seq_labels xxx = + xxx.ext_seq_labels + +(** val has_tailcalls : unserialized_params -> Bool.bool **) +let rec has_tailcalls xxx = + xxx.has_tailcalls + +type paramsT = __ + +(** val unserialized_params_inv_rect_Type4 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool + -> __ -> __ -> 'a1) -> 'a1 **) +let unserialized_params_inv_rect_Type4 hterm h1 = + let hcut = unserialized_params_rect_Type4 h1 hterm in hcut __ + +(** val unserialized_params_inv_rect_Type3 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool + -> __ -> __ -> 'a1) -> 'a1 **) +let unserialized_params_inv_rect_Type3 hterm h1 = + let hcut = unserialized_params_rect_Type3 h1 hterm in hcut __ + +(** val unserialized_params_inv_rect_Type2 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool + -> __ -> __ -> 'a1) -> 'a1 **) +let unserialized_params_inv_rect_Type2 hterm h1 = + let hcut = unserialized_params_rect_Type2 h1 hterm in hcut __ + +(** val unserialized_params_inv_rect_Type1 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool + -> __ -> __ -> 'a1) -> 'a1 **) +let unserialized_params_inv_rect_Type1 hterm h1 = + let hcut = unserialized_params_rect_Type1 h1 hterm in hcut __ + +(** val unserialized_params_inv_rect_Type0 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool + -> __ -> __ -> 'a1) -> 'a1 **) +let unserialized_params_inv_rect_Type0 hterm h1 = + let hcut = unserialized_params_rect_Type0 h1 hterm in hcut __ + +(** val unserialized_params_jmdiscr : + unserialized_params -> unserialized_params -> __ **) +let unserialized_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { ext_seq_labels = a13; has_tailcalls = a14 } = x in + Obj.magic (fun _ dH -> + dH __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __)) y + +type get_pseudo_reg_functs = { acc_a_regs : (__ -> Registers.register + List.list); + acc_b_regs : (__ -> Registers.register + List.list); + acc_a_args : (__ -> Registers.register + List.list); + acc_b_args : (__ -> Registers.register + List.list); + dpl_regs : (__ -> Registers.register + List.list); + dph_regs : (__ -> Registers.register + List.list); + dpl_args : (__ -> Registers.register + List.list); + dph_args : (__ -> Registers.register + List.list); + snd_args : (__ -> Registers.register + List.list); + pair_move_regs : (__ -> Registers.register + List.list); + f_call_args : (__ -> Registers.register + List.list); + f_call_dest : (__ -> Registers.register + List.list); + ext_seq_regs : (__ -> Registers.register + List.list); + params_regs : (__ -> Registers.register + List.list) } + +(** val get_pseudo_reg_functs_rect_Type4 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 **) +let rec get_pseudo_reg_functs_rect_Type4 p h_mk_get_pseudo_reg_functs x_16955 = + let { acc_a_regs = acc_a_regs0; acc_b_regs = acc_b_regs0; acc_a_args = + acc_a_args0; acc_b_args = acc_b_args0; dpl_regs = dpl_regs0; dph_regs = + dph_regs0; dpl_args = dpl_args0; dph_args = dph_args0; snd_args = + snd_args0; pair_move_regs = pair_move_regs0; f_call_args = f_call_args0; + f_call_dest = f_call_dest0; ext_seq_regs = ext_seq_regs0; params_regs = + params_regs0 } = x_16955 + in + h_mk_get_pseudo_reg_functs acc_a_regs0 acc_b_regs0 acc_a_args0 acc_b_args0 + dpl_regs0 dph_regs0 dpl_args0 dph_args0 snd_args0 pair_move_regs0 + f_call_args0 f_call_dest0 ext_seq_regs0 params_regs0 + +(** val get_pseudo_reg_functs_rect_Type5 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 **) +let rec get_pseudo_reg_functs_rect_Type5 p h_mk_get_pseudo_reg_functs x_16957 = + let { acc_a_regs = acc_a_regs0; acc_b_regs = acc_b_regs0; acc_a_args = + acc_a_args0; acc_b_args = acc_b_args0; dpl_regs = dpl_regs0; dph_regs = + dph_regs0; dpl_args = dpl_args0; dph_args = dph_args0; snd_args = + snd_args0; pair_move_regs = pair_move_regs0; f_call_args = f_call_args0; + f_call_dest = f_call_dest0; ext_seq_regs = ext_seq_regs0; params_regs = + params_regs0 } = x_16957 + in + h_mk_get_pseudo_reg_functs acc_a_regs0 acc_b_regs0 acc_a_args0 acc_b_args0 + dpl_regs0 dph_regs0 dpl_args0 dph_args0 snd_args0 pair_move_regs0 + f_call_args0 f_call_dest0 ext_seq_regs0 params_regs0 + +(** val get_pseudo_reg_functs_rect_Type3 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 **) +let rec get_pseudo_reg_functs_rect_Type3 p h_mk_get_pseudo_reg_functs x_16959 = + let { acc_a_regs = acc_a_regs0; acc_b_regs = acc_b_regs0; acc_a_args = + acc_a_args0; acc_b_args = acc_b_args0; dpl_regs = dpl_regs0; dph_regs = + dph_regs0; dpl_args = dpl_args0; dph_args = dph_args0; snd_args = + snd_args0; pair_move_regs = pair_move_regs0; f_call_args = f_call_args0; + f_call_dest = f_call_dest0; ext_seq_regs = ext_seq_regs0; params_regs = + params_regs0 } = x_16959 + in + h_mk_get_pseudo_reg_functs acc_a_regs0 acc_b_regs0 acc_a_args0 acc_b_args0 + dpl_regs0 dph_regs0 dpl_args0 dph_args0 snd_args0 pair_move_regs0 + f_call_args0 f_call_dest0 ext_seq_regs0 params_regs0 + +(** val get_pseudo_reg_functs_rect_Type2 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 **) +let rec get_pseudo_reg_functs_rect_Type2 p h_mk_get_pseudo_reg_functs x_16961 = + let { acc_a_regs = acc_a_regs0; acc_b_regs = acc_b_regs0; acc_a_args = + acc_a_args0; acc_b_args = acc_b_args0; dpl_regs = dpl_regs0; dph_regs = + dph_regs0; dpl_args = dpl_args0; dph_args = dph_args0; snd_args = + snd_args0; pair_move_regs = pair_move_regs0; f_call_args = f_call_args0; + f_call_dest = f_call_dest0; ext_seq_regs = ext_seq_regs0; params_regs = + params_regs0 } = x_16961 + in + h_mk_get_pseudo_reg_functs acc_a_regs0 acc_b_regs0 acc_a_args0 acc_b_args0 + dpl_regs0 dph_regs0 dpl_args0 dph_args0 snd_args0 pair_move_regs0 + f_call_args0 f_call_dest0 ext_seq_regs0 params_regs0 + +(** val get_pseudo_reg_functs_rect_Type1 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 **) +let rec get_pseudo_reg_functs_rect_Type1 p h_mk_get_pseudo_reg_functs x_16963 = + let { acc_a_regs = acc_a_regs0; acc_b_regs = acc_b_regs0; acc_a_args = + acc_a_args0; acc_b_args = acc_b_args0; dpl_regs = dpl_regs0; dph_regs = + dph_regs0; dpl_args = dpl_args0; dph_args = dph_args0; snd_args = + snd_args0; pair_move_regs = pair_move_regs0; f_call_args = f_call_args0; + f_call_dest = f_call_dest0; ext_seq_regs = ext_seq_regs0; params_regs = + params_regs0 } = x_16963 + in + h_mk_get_pseudo_reg_functs acc_a_regs0 acc_b_regs0 acc_a_args0 acc_b_args0 + dpl_regs0 dph_regs0 dpl_args0 dph_args0 snd_args0 pair_move_regs0 + f_call_args0 f_call_dest0 ext_seq_regs0 params_regs0 + +(** val get_pseudo_reg_functs_rect_Type0 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 **) +let rec get_pseudo_reg_functs_rect_Type0 p h_mk_get_pseudo_reg_functs x_16965 = + let { acc_a_regs = acc_a_regs0; acc_b_regs = acc_b_regs0; acc_a_args = + acc_a_args0; acc_b_args = acc_b_args0; dpl_regs = dpl_regs0; dph_regs = + dph_regs0; dpl_args = dpl_args0; dph_args = dph_args0; snd_args = + snd_args0; pair_move_regs = pair_move_regs0; f_call_args = f_call_args0; + f_call_dest = f_call_dest0; ext_seq_regs = ext_seq_regs0; params_regs = + params_regs0 } = x_16965 + in + h_mk_get_pseudo_reg_functs acc_a_regs0 acc_b_regs0 acc_a_args0 acc_b_args0 + dpl_regs0 dph_regs0 dpl_args0 dph_args0 snd_args0 pair_move_regs0 + f_call_args0 f_call_dest0 ext_seq_regs0 params_regs0 + +(** val acc_a_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec acc_a_regs p xxx = + xxx.acc_a_regs + +(** val acc_b_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec acc_b_regs p xxx = + xxx.acc_b_regs + +(** val acc_a_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec acc_a_args p xxx = + xxx.acc_a_args + +(** val acc_b_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec acc_b_args p xxx = + xxx.acc_b_args + +(** val dpl_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec dpl_regs p xxx = + xxx.dpl_regs + +(** val dph_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec dph_regs p xxx = + xxx.dph_regs + +(** val dpl_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec dpl_args p xxx = + xxx.dpl_args + +(** val dph_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec dph_args p xxx = + xxx.dph_args + +(** val snd_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec snd_args p xxx = + xxx.snd_args + +(** val pair_move_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec pair_move_regs p xxx = + xxx.pair_move_regs + +(** val f_call_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec f_call_args p xxx = + xxx.f_call_args + +(** val f_call_dest : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec f_call_dest p xxx = + xxx.f_call_dest + +(** val ext_seq_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec ext_seq_regs p xxx = + xxx.ext_seq_regs + +(** val params_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list **) +let rec params_regs p xxx = + xxx.params_regs + +(** val get_pseudo_reg_functs_inv_rect_Type4 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> __ -> 'a1) -> 'a1 **) +let get_pseudo_reg_functs_inv_rect_Type4 x1 hterm h1 = + let hcut = get_pseudo_reg_functs_rect_Type4 x1 h1 hterm in hcut __ + +(** val get_pseudo_reg_functs_inv_rect_Type3 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> __ -> 'a1) -> 'a1 **) +let get_pseudo_reg_functs_inv_rect_Type3 x1 hterm h1 = + let hcut = get_pseudo_reg_functs_rect_Type3 x1 h1 hterm in hcut __ + +(** val get_pseudo_reg_functs_inv_rect_Type2 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> __ -> 'a1) -> 'a1 **) +let get_pseudo_reg_functs_inv_rect_Type2 x1 hterm h1 = + let hcut = get_pseudo_reg_functs_rect_Type2 x1 h1 hterm in hcut __ + +(** val get_pseudo_reg_functs_inv_rect_Type1 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> __ -> 'a1) -> 'a1 **) +let get_pseudo_reg_functs_inv_rect_Type1 x1 hterm h1 = + let hcut = get_pseudo_reg_functs_rect_Type1 x1 h1 hterm in hcut __ + +(** val get_pseudo_reg_functs_inv_rect_Type0 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> __ -> 'a1) -> 'a1 **) +let get_pseudo_reg_functs_inv_rect_Type0 x1 hterm h1 = + let hcut = get_pseudo_reg_functs_rect_Type0 x1 h1 hterm in hcut __ + +(** val get_pseudo_reg_functs_jmdiscr : + unserialized_params -> get_pseudo_reg_functs -> get_pseudo_reg_functs -> + __ **) +let get_pseudo_reg_functs_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { acc_a_regs = a0; acc_b_regs = a10; acc_a_args = a2; acc_b_args = + a3; dpl_regs = a4; dph_regs = a5; dpl_args = a6; dph_args = a7; + snd_args = a8; pair_move_regs = a9; f_call_args = a100; f_call_dest = + a11; ext_seq_regs = a12; params_regs = a13 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __ __ __ __)) y + +type uns_params = { u_pars : unserialized_params; + functs : get_pseudo_reg_functs } + +(** val uns_params_rect_Type4 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> + 'a1 **) +let rec uns_params_rect_Type4 h_mk_uns_params x_16995 = + let { u_pars = u_pars0; functs = functs0 } = x_16995 in + h_mk_uns_params u_pars0 functs0 + +(** val uns_params_rect_Type5 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> + 'a1 **) +let rec uns_params_rect_Type5 h_mk_uns_params x_16997 = + let { u_pars = u_pars0; functs = functs0 } = x_16997 in + h_mk_uns_params u_pars0 functs0 + +(** val uns_params_rect_Type3 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> + 'a1 **) +let rec uns_params_rect_Type3 h_mk_uns_params x_16999 = + let { u_pars = u_pars0; functs = functs0 } = x_16999 in + h_mk_uns_params u_pars0 functs0 + +(** val uns_params_rect_Type2 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> + 'a1 **) +let rec uns_params_rect_Type2 h_mk_uns_params x_17001 = + let { u_pars = u_pars0; functs = functs0 } = x_17001 in + h_mk_uns_params u_pars0 functs0 + +(** val uns_params_rect_Type1 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> + 'a1 **) +let rec uns_params_rect_Type1 h_mk_uns_params x_17003 = + let { u_pars = u_pars0; functs = functs0 } = x_17003 in + h_mk_uns_params u_pars0 functs0 + +(** val uns_params_rect_Type0 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> + 'a1 **) +let rec uns_params_rect_Type0 h_mk_uns_params x_17005 = + let { u_pars = u_pars0; functs = functs0 } = x_17005 in + h_mk_uns_params u_pars0 functs0 + +(** val u_pars : uns_params -> unserialized_params **) +let rec u_pars xxx = + xxx.u_pars + +(** val functs : uns_params -> get_pseudo_reg_functs **) +let rec functs xxx = + xxx.functs + +(** val uns_params_inv_rect_Type4 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 **) +let uns_params_inv_rect_Type4 hterm h1 = + let hcut = uns_params_rect_Type4 h1 hterm in hcut __ + +(** val uns_params_inv_rect_Type3 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 **) +let uns_params_inv_rect_Type3 hterm h1 = + let hcut = uns_params_rect_Type3 h1 hterm in hcut __ + +(** val uns_params_inv_rect_Type2 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 **) +let uns_params_inv_rect_Type2 hterm h1 = + let hcut = uns_params_rect_Type2 h1 hterm in hcut __ + +(** val uns_params_inv_rect_Type1 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 **) +let uns_params_inv_rect_Type1 hterm h1 = + let hcut = uns_params_rect_Type1 h1 hterm in hcut __ + +(** val uns_params_inv_rect_Type0 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 **) +let uns_params_inv_rect_Type0 hterm h1 = + let hcut = uns_params_rect_Type0 h1 hterm in hcut __ + +(** val uns_params_jmdiscr : uns_params -> uns_params -> __ **) +let uns_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { u_pars = a0; functs = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +type joint_seq = +| COMMENT of String.string +| MOVE of __ +| POP of __ +| PUSH of __ +| ADDRESS of AST.ident * BitVector.word * __ * __ +| OPACCS of BackEndOps.opAccs * __ * __ * __ * __ +| OP1 of BackEndOps.op1 * __ * __ +| OP2 of BackEndOps.op2 * __ * __ * __ +| CLEAR_CARRY +| SET_CARRY +| LOAD of __ * __ * __ +| STORE of __ * __ * __ +| Extension_seq of __ + +(** val joint_seq_rect_Type4 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> + BitVector.word -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> + __ -> __ -> 'a1) -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> + (BackEndOps.op2 -> __ -> __ -> __ -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> 'a1) -> (__ -> 'a1) -> joint_seq -> 'a1 **) +let rec joint_seq_rect_Type4 p globals h_COMMENT h_MOVE h_POP h_PUSH h_ADDRESS h_OPACCS h_OP1 h_OP2 h_CLEAR_CARRY h_SET_CARRY h_LOAD h_STORE h_extension_seq = function +| COMMENT x_17061 -> h_COMMENT x_17061 +| MOVE x_17062 -> h_MOVE x_17062 +| POP x_17063 -> h_POP x_17063 +| PUSH x_17064 -> h_PUSH x_17064 +| ADDRESS (i, x_17067, x_17066, x_17065) -> + h_ADDRESS i __ x_17067 x_17066 x_17065 +| OPACCS (x_17073, x_17072, x_17071, x_17070, x_17069) -> + h_OPACCS x_17073 x_17072 x_17071 x_17070 x_17069 +| OP1 (x_17076, x_17075, x_17074) -> h_OP1 x_17076 x_17075 x_17074 +| OP2 (x_17080, x_17079, x_17078, x_17077) -> + h_OP2 x_17080 x_17079 x_17078 x_17077 +| CLEAR_CARRY -> h_CLEAR_CARRY +| SET_CARRY -> h_SET_CARRY +| LOAD (x_17083, x_17082, x_17081) -> h_LOAD x_17083 x_17082 x_17081 +| STORE (x_17086, x_17085, x_17084) -> h_STORE x_17086 x_17085 x_17084 +| Extension_seq x_17087 -> h_extension_seq x_17087 + +(** val joint_seq_rect_Type5 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> + BitVector.word -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> + __ -> __ -> 'a1) -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> + (BackEndOps.op2 -> __ -> __ -> __ -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> 'a1) -> (__ -> 'a1) -> joint_seq -> 'a1 **) +let rec joint_seq_rect_Type5 p globals h_COMMENT h_MOVE h_POP h_PUSH h_ADDRESS h_OPACCS h_OP1 h_OP2 h_CLEAR_CARRY h_SET_CARRY h_LOAD h_STORE h_extension_seq = function +| COMMENT x_17102 -> h_COMMENT x_17102 +| MOVE x_17103 -> h_MOVE x_17103 +| POP x_17104 -> h_POP x_17104 +| PUSH x_17105 -> h_PUSH x_17105 +| ADDRESS (i, x_17108, x_17107, x_17106) -> + h_ADDRESS i __ x_17108 x_17107 x_17106 +| OPACCS (x_17114, x_17113, x_17112, x_17111, x_17110) -> + h_OPACCS x_17114 x_17113 x_17112 x_17111 x_17110 +| OP1 (x_17117, x_17116, x_17115) -> h_OP1 x_17117 x_17116 x_17115 +| OP2 (x_17121, x_17120, x_17119, x_17118) -> + h_OP2 x_17121 x_17120 x_17119 x_17118 +| CLEAR_CARRY -> h_CLEAR_CARRY +| SET_CARRY -> h_SET_CARRY +| LOAD (x_17124, x_17123, x_17122) -> h_LOAD x_17124 x_17123 x_17122 +| STORE (x_17127, x_17126, x_17125) -> h_STORE x_17127 x_17126 x_17125 +| Extension_seq x_17128 -> h_extension_seq x_17128 + +(** val joint_seq_rect_Type3 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> + BitVector.word -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> + __ -> __ -> 'a1) -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> + (BackEndOps.op2 -> __ -> __ -> __ -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> 'a1) -> (__ -> 'a1) -> joint_seq -> 'a1 **) +let rec joint_seq_rect_Type3 p globals h_COMMENT h_MOVE h_POP h_PUSH h_ADDRESS h_OPACCS h_OP1 h_OP2 h_CLEAR_CARRY h_SET_CARRY h_LOAD h_STORE h_extension_seq = function +| COMMENT x_17143 -> h_COMMENT x_17143 +| MOVE x_17144 -> h_MOVE x_17144 +| POP x_17145 -> h_POP x_17145 +| PUSH x_17146 -> h_PUSH x_17146 +| ADDRESS (i, x_17149, x_17148, x_17147) -> + h_ADDRESS i __ x_17149 x_17148 x_17147 +| OPACCS (x_17155, x_17154, x_17153, x_17152, x_17151) -> + h_OPACCS x_17155 x_17154 x_17153 x_17152 x_17151 +| OP1 (x_17158, x_17157, x_17156) -> h_OP1 x_17158 x_17157 x_17156 +| OP2 (x_17162, x_17161, x_17160, x_17159) -> + h_OP2 x_17162 x_17161 x_17160 x_17159 +| CLEAR_CARRY -> h_CLEAR_CARRY +| SET_CARRY -> h_SET_CARRY +| LOAD (x_17165, x_17164, x_17163) -> h_LOAD x_17165 x_17164 x_17163 +| STORE (x_17168, x_17167, x_17166) -> h_STORE x_17168 x_17167 x_17166 +| Extension_seq x_17169 -> h_extension_seq x_17169 + +(** val joint_seq_rect_Type2 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> + BitVector.word -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> + __ -> __ -> 'a1) -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> + (BackEndOps.op2 -> __ -> __ -> __ -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> 'a1) -> (__ -> 'a1) -> joint_seq -> 'a1 **) +let rec joint_seq_rect_Type2 p globals h_COMMENT h_MOVE h_POP h_PUSH h_ADDRESS h_OPACCS h_OP1 h_OP2 h_CLEAR_CARRY h_SET_CARRY h_LOAD h_STORE h_extension_seq = function +| COMMENT x_17184 -> h_COMMENT x_17184 +| MOVE x_17185 -> h_MOVE x_17185 +| POP x_17186 -> h_POP x_17186 +| PUSH x_17187 -> h_PUSH x_17187 +| ADDRESS (i, x_17190, x_17189, x_17188) -> + h_ADDRESS i __ x_17190 x_17189 x_17188 +| OPACCS (x_17196, x_17195, x_17194, x_17193, x_17192) -> + h_OPACCS x_17196 x_17195 x_17194 x_17193 x_17192 +| OP1 (x_17199, x_17198, x_17197) -> h_OP1 x_17199 x_17198 x_17197 +| OP2 (x_17203, x_17202, x_17201, x_17200) -> + h_OP2 x_17203 x_17202 x_17201 x_17200 +| CLEAR_CARRY -> h_CLEAR_CARRY +| SET_CARRY -> h_SET_CARRY +| LOAD (x_17206, x_17205, x_17204) -> h_LOAD x_17206 x_17205 x_17204 +| STORE (x_17209, x_17208, x_17207) -> h_STORE x_17209 x_17208 x_17207 +| Extension_seq x_17210 -> h_extension_seq x_17210 + +(** val joint_seq_rect_Type1 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> + BitVector.word -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> + __ -> __ -> 'a1) -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> + (BackEndOps.op2 -> __ -> __ -> __ -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> 'a1) -> (__ -> 'a1) -> joint_seq -> 'a1 **) +let rec joint_seq_rect_Type1 p globals h_COMMENT h_MOVE h_POP h_PUSH h_ADDRESS h_OPACCS h_OP1 h_OP2 h_CLEAR_CARRY h_SET_CARRY h_LOAD h_STORE h_extension_seq = function +| COMMENT x_17225 -> h_COMMENT x_17225 +| MOVE x_17226 -> h_MOVE x_17226 +| POP x_17227 -> h_POP x_17227 +| PUSH x_17228 -> h_PUSH x_17228 +| ADDRESS (i, x_17231, x_17230, x_17229) -> + h_ADDRESS i __ x_17231 x_17230 x_17229 +| OPACCS (x_17237, x_17236, x_17235, x_17234, x_17233) -> + h_OPACCS x_17237 x_17236 x_17235 x_17234 x_17233 +| OP1 (x_17240, x_17239, x_17238) -> h_OP1 x_17240 x_17239 x_17238 +| OP2 (x_17244, x_17243, x_17242, x_17241) -> + h_OP2 x_17244 x_17243 x_17242 x_17241 +| CLEAR_CARRY -> h_CLEAR_CARRY +| SET_CARRY -> h_SET_CARRY +| LOAD (x_17247, x_17246, x_17245) -> h_LOAD x_17247 x_17246 x_17245 +| STORE (x_17250, x_17249, x_17248) -> h_STORE x_17250 x_17249 x_17248 +| Extension_seq x_17251 -> h_extension_seq x_17251 + +(** val joint_seq_rect_Type0 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> + BitVector.word -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> + __ -> __ -> 'a1) -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> + (BackEndOps.op2 -> __ -> __ -> __ -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> 'a1) -> (__ -> 'a1) -> joint_seq -> 'a1 **) +let rec joint_seq_rect_Type0 p globals h_COMMENT h_MOVE h_POP h_PUSH h_ADDRESS h_OPACCS h_OP1 h_OP2 h_CLEAR_CARRY h_SET_CARRY h_LOAD h_STORE h_extension_seq = function +| COMMENT x_17266 -> h_COMMENT x_17266 +| MOVE x_17267 -> h_MOVE x_17267 +| POP x_17268 -> h_POP x_17268 +| PUSH x_17269 -> h_PUSH x_17269 +| ADDRESS (i, x_17272, x_17271, x_17270) -> + h_ADDRESS i __ x_17272 x_17271 x_17270 +| OPACCS (x_17278, x_17277, x_17276, x_17275, x_17274) -> + h_OPACCS x_17278 x_17277 x_17276 x_17275 x_17274 +| OP1 (x_17281, x_17280, x_17279) -> h_OP1 x_17281 x_17280 x_17279 +| OP2 (x_17285, x_17284, x_17283, x_17282) -> + h_OP2 x_17285 x_17284 x_17283 x_17282 +| CLEAR_CARRY -> h_CLEAR_CARRY +| SET_CARRY -> h_SET_CARRY +| LOAD (x_17288, x_17287, x_17286) -> h_LOAD x_17288 x_17287 x_17286 +| STORE (x_17291, x_17290, x_17289) -> h_STORE x_17291 x_17290 x_17289 +| Extension_seq x_17292 -> h_extension_seq x_17292 + +(** val joint_seq_inv_rect_Type4 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.op1 -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ + -> __ -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 **) +let joint_seq_inv_rect_Type4 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + joint_seq_rect_Type4 x1 x2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + hterm + in + hcut __ + +(** val joint_seq_inv_rect_Type3 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.op1 -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ + -> __ -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 **) +let joint_seq_inv_rect_Type3 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + joint_seq_rect_Type3 x1 x2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + hterm + in + hcut __ + +(** val joint_seq_inv_rect_Type2 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.op1 -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ + -> __ -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 **) +let joint_seq_inv_rect_Type2 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + joint_seq_rect_Type2 x1 x2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + hterm + in + hcut __ + +(** val joint_seq_inv_rect_Type1 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.op1 -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ + -> __ -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 **) +let joint_seq_inv_rect_Type1 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + joint_seq_rect_Type1 x1 x2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + hterm + in + hcut __ + +(** val joint_seq_inv_rect_Type0 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.op1 -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ + -> __ -> __ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 **) +let joint_seq_inv_rect_Type0 x1 x2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 = + let hcut = + joint_seq_rect_Type0 x1 x2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 + hterm + in + hcut __ + +(** val joint_seq_discr : + unserialized_params -> AST.ident List.list -> joint_seq -> joint_seq -> + __ **) +let joint_seq_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | COMMENT a0 -> Obj.magic (fun _ dH -> dH __) + | MOVE a0 -> Obj.magic (fun _ dH -> dH __) + | POP a0 -> Obj.magic (fun _ dH -> dH __) + | PUSH a0 -> Obj.magic (fun _ dH -> dH __) + | ADDRESS (a0, a20, a3, a4) -> Obj.magic (fun _ dH -> dH __ __ __ __ __) + | OPACCS (a0, a10, a20, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | OP1 (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | OP2 (a0, a10, a20, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | CLEAR_CARRY -> Obj.magic (fun _ dH -> dH) + | SET_CARRY -> Obj.magic (fun _ dH -> dH) + | LOAD (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | STORE (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Extension_seq a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val joint_seq_jmdiscr : + unserialized_params -> AST.ident List.list -> joint_seq -> joint_seq -> + __ **) +let joint_seq_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | COMMENT a0 -> Obj.magic (fun _ dH -> dH __) + | MOVE a0 -> Obj.magic (fun _ dH -> dH __) + | POP a0 -> Obj.magic (fun _ dH -> dH __) + | PUSH a0 -> Obj.magic (fun _ dH -> dH __) + | ADDRESS (a0, a20, a3, a4) -> Obj.magic (fun _ dH -> dH __ __ __ __ __) + | OPACCS (a0, a10, a20, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | OP1 (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | OP2 (a0, a10, a20, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | CLEAR_CARRY -> Obj.magic (fun _ dH -> dH) + | SET_CARRY -> Obj.magic (fun _ dH -> dH) + | LOAD (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | STORE (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Extension_seq a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val get_used_registers_from_seq : + unserialized_params -> AST.ident List.list -> get_pseudo_reg_functs -> + joint_seq -> Registers.register List.list **) +let get_used_registers_from_seq p globals functs0 = function +| COMMENT x -> List.Nil +| MOVE pm -> functs0.pair_move_regs pm +| POP r -> functs0.acc_a_regs r +| PUSH r -> functs0.acc_a_args r +| ADDRESS (x, x1, r1, r2) -> + List.append (functs0.dpl_regs r1) (functs0.dph_regs r2) +| OPACCS (o, r1, r2, r3, r4) -> + List.append (functs0.acc_a_regs r1) + (List.append (functs0.acc_b_regs r2) + (List.append (functs0.acc_a_args r3) (functs0.acc_b_args r4))) +| OP1 (o, r1, r2) -> + List.append (functs0.acc_a_regs r1) (functs0.acc_a_regs r2) +| OP2 (o, r1, r2, r3) -> + List.append (functs0.acc_a_regs r1) + (List.append (functs0.acc_a_args r2) (functs0.snd_args r3)) +| CLEAR_CARRY -> List.Nil +| SET_CARRY -> List.Nil +| LOAD (r1, r2, r3) -> + List.append (functs0.acc_a_regs r1) + (List.append (functs0.dpl_args r2) (functs0.dph_args r3)) +| STORE (r1, r2, r3) -> + List.append (functs0.dpl_args r1) + (List.append (functs0.dph_args r2) (functs0.acc_a_args r3)) +| Extension_seq ext -> functs0.ext_seq_regs ext + +(** val nOOP : unserialized_params -> AST.ident List.list -> joint_seq **) +let nOOP p globals = + COMMENT String.EmptyString + +(** val dpi1__o__extension_seq_to_seq__o__inject : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_seq Types.sig0 **) +let dpi1__o__extension_seq_to_seq__o__inject x0 x1 x4 = + Extension_seq x4.Types.dpi1 + +(** val eject__o__extension_seq_to_seq__o__inject : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_seq + Types.sig0 **) +let eject__o__extension_seq_to_seq__o__inject x0 x1 x4 = + Extension_seq (Types.pi1 x4) + +(** val extension_seq_to_seq__o__inject : + unserialized_params -> AST.ident List.list -> __ -> joint_seq Types.sig0 **) +let extension_seq_to_seq__o__inject x0 x1 x3 = + Extension_seq x3 + +(** val dpi1__o__extension_seq_to_seq : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_seq **) +let dpi1__o__extension_seq_to_seq x0 x1 x3 = + Extension_seq x3.Types.dpi1 + +(** val eject__o__extension_seq_to_seq : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_seq **) +let eject__o__extension_seq_to_seq x0 x1 x3 = + Extension_seq (Types.pi1 x3) + +type joint_step = +| COST_LABEL of CostLabel.costlabel +| CALL of (AST.ident, (__, __) Types.prod) Types.sum * __ * __ +| COND of __ * Graphs.label +| Step_seq of joint_seq + +(** val joint_step_rect_Type4 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> + 'a1) -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) + -> (__ -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 **) +let rec joint_step_rect_Type4 p globals h_COST_LABEL h_CALL h_COND h_step_seq = function +| COST_LABEL x_17565 -> h_COST_LABEL x_17565 +| CALL (x_17568, x_17567, x_17566) -> h_CALL x_17568 x_17567 x_17566 +| COND (x_17570, x_17569) -> h_COND x_17570 x_17569 +| Step_seq x_17571 -> h_step_seq x_17571 + +(** val joint_step_rect_Type5 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> + 'a1) -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) + -> (__ -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 **) +let rec joint_step_rect_Type5 p globals h_COST_LABEL h_CALL h_COND h_step_seq = function +| COST_LABEL x_17577 -> h_COST_LABEL x_17577 +| CALL (x_17580, x_17579, x_17578) -> h_CALL x_17580 x_17579 x_17578 +| COND (x_17582, x_17581) -> h_COND x_17582 x_17581 +| Step_seq x_17583 -> h_step_seq x_17583 + +(** val joint_step_rect_Type3 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> + 'a1) -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) + -> (__ -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 **) +let rec joint_step_rect_Type3 p globals h_COST_LABEL h_CALL h_COND h_step_seq = function +| COST_LABEL x_17589 -> h_COST_LABEL x_17589 +| CALL (x_17592, x_17591, x_17590) -> h_CALL x_17592 x_17591 x_17590 +| COND (x_17594, x_17593) -> h_COND x_17594 x_17593 +| Step_seq x_17595 -> h_step_seq x_17595 + +(** val joint_step_rect_Type2 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> + 'a1) -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) + -> (__ -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 **) +let rec joint_step_rect_Type2 p globals h_COST_LABEL h_CALL h_COND h_step_seq = function +| COST_LABEL x_17601 -> h_COST_LABEL x_17601 +| CALL (x_17604, x_17603, x_17602) -> h_CALL x_17604 x_17603 x_17602 +| COND (x_17606, x_17605) -> h_COND x_17606 x_17605 +| Step_seq x_17607 -> h_step_seq x_17607 + +(** val joint_step_rect_Type1 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> + 'a1) -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) + -> (__ -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 **) +let rec joint_step_rect_Type1 p globals h_COST_LABEL h_CALL h_COND h_step_seq = function +| COST_LABEL x_17613 -> h_COST_LABEL x_17613 +| CALL (x_17616, x_17615, x_17614) -> h_CALL x_17616 x_17615 x_17614 +| COND (x_17618, x_17617) -> h_COND x_17618 x_17617 +| Step_seq x_17619 -> h_step_seq x_17619 + +(** val joint_step_rect_Type0 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> + 'a1) -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) + -> (__ -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 **) +let rec joint_step_rect_Type0 p globals h_COST_LABEL h_CALL h_COND h_step_seq = function +| COST_LABEL x_17625 -> h_COST_LABEL x_17625 +| CALL (x_17628, x_17627, x_17626) -> h_CALL x_17628 x_17627 x_17626 +| COND (x_17630, x_17629) -> h_COND x_17630 x_17629 +| Step_seq x_17631 -> h_step_seq x_17631 + +(** val joint_step_inv_rect_Type4 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) + -> (joint_seq -> __ -> 'a1) -> 'a1 **) +let joint_step_inv_rect_Type4 x1 x2 hterm h1 h2 h3 h4 = + let hcut = joint_step_rect_Type4 x1 x2 h1 h2 h3 h4 hterm in hcut __ + +(** val joint_step_inv_rect_Type3 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) + -> (joint_seq -> __ -> 'a1) -> 'a1 **) +let joint_step_inv_rect_Type3 x1 x2 hterm h1 h2 h3 h4 = + let hcut = joint_step_rect_Type3 x1 x2 h1 h2 h3 h4 hterm in hcut __ + +(** val joint_step_inv_rect_Type2 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) + -> (joint_seq -> __ -> 'a1) -> 'a1 **) +let joint_step_inv_rect_Type2 x1 x2 hterm h1 h2 h3 h4 = + let hcut = joint_step_rect_Type2 x1 x2 h1 h2 h3 h4 hterm in hcut __ + +(** val joint_step_inv_rect_Type1 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) + -> (joint_seq -> __ -> 'a1) -> 'a1 **) +let joint_step_inv_rect_Type1 x1 x2 hterm h1 h2 h3 h4 = + let hcut = joint_step_rect_Type1 x1 x2 h1 h2 h3 h4 hterm in hcut __ + +(** val joint_step_inv_rect_Type0 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) + -> (joint_seq -> __ -> 'a1) -> 'a1 **) +let joint_step_inv_rect_Type0 x1 x2 hterm h1 h2 h3 h4 = + let hcut = joint_step_rect_Type0 x1 x2 h1 h2 h3 h4 hterm in hcut __ + +(** val joint_step_discr : + unserialized_params -> AST.ident List.list -> joint_step -> joint_step -> + __ **) +let joint_step_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | COST_LABEL a0 -> Obj.magic (fun _ dH -> dH __) + | CALL (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | COND (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Step_seq a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val joint_step_jmdiscr : + unserialized_params -> AST.ident List.list -> joint_step -> joint_step -> + __ **) +let joint_step_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | COST_LABEL a0 -> Obj.magic (fun _ dH -> dH __) + | CALL (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | COND (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Step_seq a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val get_used_registers_from_step : + unserialized_params -> AST.ident List.list -> get_pseudo_reg_functs -> + joint_step -> Registers.register List.list **) +let get_used_registers_from_step p globals functs0 = function +| COST_LABEL c -> List.Nil +| CALL (id, args, dest) -> + let r_id = + match id with + | Types.Inl x -> List.Nil + | Types.Inr ptr -> + List.append (functs0.dpl_args ptr.Types.fst) + (functs0.dph_args ptr.Types.snd) + in + List.append r_id + (List.append (functs0.f_call_args args) (functs0.f_call_dest dest)) +| COND (r, lbl) -> functs0.acc_a_regs r +| Step_seq s -> get_used_registers_from_seq p globals functs0 s + +(** val dpi1__o__extension_seq_to_seq__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_step Types.sig0 **) +let dpi1__o__extension_seq_to_seq__o__seq_to_step__o__inject x0 x1 x4 = + Step_seq (dpi1__o__extension_seq_to_seq x0 x1 x4) + +(** val eject__o__extension_seq_to_seq__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_step + Types.sig0 **) +let eject__o__extension_seq_to_seq__o__seq_to_step__o__inject x0 x1 x4 = + Step_seq (eject__o__extension_seq_to_seq x0 x1 x4) + +(** val extension_seq_to_seq__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> __ -> joint_step Types.sig0 **) +let extension_seq_to_seq__o__seq_to_step__o__inject x0 x1 x2 = + Step_seq (Extension_seq x2) + +(** val dpi1__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> (joint_seq, 'a1) + Types.dPair -> joint_step Types.sig0 **) +let dpi1__o__seq_to_step__o__inject x0 x1 x4 = + Step_seq x4.Types.dpi1 + +(** val eject__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> joint_seq Types.sig0 -> + joint_step Types.sig0 **) +let eject__o__seq_to_step__o__inject x0 x1 x4 = + Step_seq (Types.pi1 x4) + +(** val seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> joint_seq -> joint_step + Types.sig0 **) +let seq_to_step__o__inject x0 x1 x3 = + Step_seq x3 + +(** val dpi1__o__extension_seq_to_seq__o__seq_to_step : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_step **) +let dpi1__o__extension_seq_to_seq__o__seq_to_step x0 x1 x3 = + Step_seq (dpi1__o__extension_seq_to_seq x0 x1 x3) + +(** val eject__o__extension_seq_to_seq__o__seq_to_step : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_step **) +let eject__o__extension_seq_to_seq__o__seq_to_step x0 x1 x3 = + Step_seq (eject__o__extension_seq_to_seq x0 x1 x3) + +(** val extension_seq_to_seq__o__seq_to_step : + unserialized_params -> AST.ident List.list -> __ -> joint_step **) +let extension_seq_to_seq__o__seq_to_step x0 x1 x2 = + Step_seq (Extension_seq x2) + +(** val dpi1__o__seq_to_step : + unserialized_params -> AST.ident List.list -> (joint_seq, 'a1) + Types.dPair -> joint_step **) +let dpi1__o__seq_to_step x0 x1 x3 = + Step_seq x3.Types.dpi1 + +(** val eject__o__seq_to_step : + unserialized_params -> AST.ident List.list -> joint_seq Types.sig0 -> + joint_step **) +let eject__o__seq_to_step x0 x1 x3 = + Step_seq (Types.pi1 x3) + +(** val step_labels : + unserialized_params -> AST.ident List.list -> joint_step -> Graphs.label + List.list **) +let step_labels p globals = function +| COST_LABEL x -> List.Nil +| CALL (x, x0, x1) -> List.Nil +| COND (x, l) -> List.Cons (l, List.Nil) +| Step_seq s0 -> + (match s0 with + | COMMENT x -> List.Nil + | MOVE x -> List.Nil + | POP x -> List.Nil + | PUSH x -> List.Nil + | ADDRESS (x, x1, x2, x3) -> List.Nil + | OPACCS (x, x0, x1, x2, x3) -> List.Nil + | OP1 (x, x0, x1) -> List.Nil + | OP2 (x, x0, x1, x2) -> List.Nil + | CLEAR_CARRY -> List.Nil + | SET_CARRY -> List.Nil + | LOAD (x, x0, x1) -> List.Nil + | STORE (x, x0, x1) -> List.Nil + | Extension_seq ext -> p.ext_seq_labels ext) + +type stmt_params = { uns_pars : uns_params; + succ_label : (__ -> Graphs.label Types.option); + has_fcond : Bool.bool } + +(** val stmt_params_rect_Type4 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> + 'a1) -> stmt_params -> 'a1 **) +let rec stmt_params_rect_Type4 h_mk_stmt_params x_17710 = + let { uns_pars = uns_pars0; succ_label = succ_label0; has_fcond = + has_fcond0 } = x_17710 + in + h_mk_stmt_params uns_pars0 __ succ_label0 has_fcond0 + +(** val stmt_params_rect_Type5 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> + 'a1) -> stmt_params -> 'a1 **) +let rec stmt_params_rect_Type5 h_mk_stmt_params x_17712 = + let { uns_pars = uns_pars0; succ_label = succ_label0; has_fcond = + has_fcond0 } = x_17712 + in + h_mk_stmt_params uns_pars0 __ succ_label0 has_fcond0 + +(** val stmt_params_rect_Type3 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> + 'a1) -> stmt_params -> 'a1 **) +let rec stmt_params_rect_Type3 h_mk_stmt_params x_17714 = + let { uns_pars = uns_pars0; succ_label = succ_label0; has_fcond = + has_fcond0 } = x_17714 + in + h_mk_stmt_params uns_pars0 __ succ_label0 has_fcond0 + +(** val stmt_params_rect_Type2 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> + 'a1) -> stmt_params -> 'a1 **) +let rec stmt_params_rect_Type2 h_mk_stmt_params x_17716 = + let { uns_pars = uns_pars0; succ_label = succ_label0; has_fcond = + has_fcond0 } = x_17716 + in + h_mk_stmt_params uns_pars0 __ succ_label0 has_fcond0 + +(** val stmt_params_rect_Type1 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> + 'a1) -> stmt_params -> 'a1 **) +let rec stmt_params_rect_Type1 h_mk_stmt_params x_17718 = + let { uns_pars = uns_pars0; succ_label = succ_label0; has_fcond = + has_fcond0 } = x_17718 + in + h_mk_stmt_params uns_pars0 __ succ_label0 has_fcond0 + +(** val stmt_params_rect_Type0 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> + 'a1) -> stmt_params -> 'a1 **) +let rec stmt_params_rect_Type0 h_mk_stmt_params x_17720 = + let { uns_pars = uns_pars0; succ_label = succ_label0; has_fcond = + has_fcond0 } = x_17720 + in + h_mk_stmt_params uns_pars0 __ succ_label0 has_fcond0 + +(** val uns_pars : stmt_params -> uns_params **) +let rec uns_pars xxx = + xxx.uns_pars + +type succ = __ + +(** val succ_label : stmt_params -> __ -> Graphs.label Types.option **) +let rec succ_label xxx = + xxx.succ_label + +(** val has_fcond : stmt_params -> Bool.bool **) +let rec has_fcond xxx = + xxx.has_fcond + +(** val stmt_params_inv_rect_Type4 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 **) +let stmt_params_inv_rect_Type4 hterm h1 = + let hcut = stmt_params_rect_Type4 h1 hterm in hcut __ + +(** val stmt_params_inv_rect_Type3 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 **) +let stmt_params_inv_rect_Type3 hterm h1 = + let hcut = stmt_params_rect_Type3 h1 hterm in hcut __ + +(** val stmt_params_inv_rect_Type2 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 **) +let stmt_params_inv_rect_Type2 hterm h1 = + let hcut = stmt_params_rect_Type2 h1 hterm in hcut __ + +(** val stmt_params_inv_rect_Type1 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 **) +let stmt_params_inv_rect_Type1 hterm h1 = + let hcut = stmt_params_rect_Type1 h1 hterm in hcut __ + +(** val stmt_params_inv_rect_Type0 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 **) +let stmt_params_inv_rect_Type0 hterm h1 = + let hcut = stmt_params_rect_Type0 h1 hterm in hcut __ + +(** val stmt_params_jmdiscr : stmt_params -> stmt_params -> __ **) +let stmt_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { uns_pars = a0; succ_label = a2; has_fcond = a3 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val uns_pars__o__u_pars : stmt_params -> unserialized_params **) +let uns_pars__o__u_pars x0 = + x0.uns_pars.u_pars + +type joint_fin_step = +| GOTO of Graphs.label +| RETURN +| TAILCALL of (AST.ident, (__, __) Types.prod) Types.sum * __ + +(** val joint_fin_step_rect_Type4 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 **) +let rec joint_fin_step_rect_Type4 p h_GOTO h_RETURN h_TAILCALL = function +| GOTO x_17744 -> h_GOTO x_17744 +| RETURN -> h_RETURN +| TAILCALL (x_17746, x_17745) -> h_TAILCALL __ x_17746 x_17745 + +(** val joint_fin_step_rect_Type5 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 **) +let rec joint_fin_step_rect_Type5 p h_GOTO h_RETURN h_TAILCALL = function +| GOTO x_17752 -> h_GOTO x_17752 +| RETURN -> h_RETURN +| TAILCALL (x_17754, x_17753) -> h_TAILCALL __ x_17754 x_17753 + +(** val joint_fin_step_rect_Type3 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 **) +let rec joint_fin_step_rect_Type3 p h_GOTO h_RETURN h_TAILCALL = function +| GOTO x_17760 -> h_GOTO x_17760 +| RETURN -> h_RETURN +| TAILCALL (x_17762, x_17761) -> h_TAILCALL __ x_17762 x_17761 + +(** val joint_fin_step_rect_Type2 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 **) +let rec joint_fin_step_rect_Type2 p h_GOTO h_RETURN h_TAILCALL = function +| GOTO x_17768 -> h_GOTO x_17768 +| RETURN -> h_RETURN +| TAILCALL (x_17770, x_17769) -> h_TAILCALL __ x_17770 x_17769 + +(** val joint_fin_step_rect_Type1 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 **) +let rec joint_fin_step_rect_Type1 p h_GOTO h_RETURN h_TAILCALL = function +| GOTO x_17776 -> h_GOTO x_17776 +| RETURN -> h_RETURN +| TAILCALL (x_17778, x_17777) -> h_TAILCALL __ x_17778 x_17777 + +(** val joint_fin_step_rect_Type0 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 **) +let rec joint_fin_step_rect_Type0 p h_GOTO h_RETURN h_TAILCALL = function +| GOTO x_17784 -> h_GOTO x_17784 +| RETURN -> h_RETURN +| TAILCALL (x_17786, x_17785) -> h_TAILCALL __ x_17786 x_17785 + +(** val joint_fin_step_inv_rect_Type4 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> + (__ -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> + __ -> 'a1) -> 'a1 **) +let joint_fin_step_inv_rect_Type4 x1 hterm h1 h2 h3 = + let hcut = joint_fin_step_rect_Type4 x1 h1 h2 h3 hterm in hcut __ + +(** val joint_fin_step_inv_rect_Type3 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> + (__ -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> + __ -> 'a1) -> 'a1 **) +let joint_fin_step_inv_rect_Type3 x1 hterm h1 h2 h3 = + let hcut = joint_fin_step_rect_Type3 x1 h1 h2 h3 hterm in hcut __ + +(** val joint_fin_step_inv_rect_Type2 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> + (__ -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> + __ -> 'a1) -> 'a1 **) +let joint_fin_step_inv_rect_Type2 x1 hterm h1 h2 h3 = + let hcut = joint_fin_step_rect_Type2 x1 h1 h2 h3 hterm in hcut __ + +(** val joint_fin_step_inv_rect_Type1 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> + (__ -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> + __ -> 'a1) -> 'a1 **) +let joint_fin_step_inv_rect_Type1 x1 hterm h1 h2 h3 = + let hcut = joint_fin_step_rect_Type1 x1 h1 h2 h3 hterm in hcut __ + +(** val joint_fin_step_inv_rect_Type0 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> + (__ -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> + __ -> 'a1) -> 'a1 **) +let joint_fin_step_inv_rect_Type0 x1 hterm h1 h2 h3 = + let hcut = joint_fin_step_rect_Type0 x1 h1 h2 h3 hterm in hcut __ + +(** val joint_fin_step_discr : + unserialized_params -> joint_fin_step -> joint_fin_step -> __ **) +let joint_fin_step_discr a1 x y = + Logic.eq_rect_Type2 x + (match x with + | GOTO a0 -> Obj.magic (fun _ dH -> dH __) + | RETURN -> Obj.magic (fun _ dH -> dH) + | TAILCALL (a10, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val joint_fin_step_jmdiscr : + unserialized_params -> joint_fin_step -> joint_fin_step -> __ **) +let joint_fin_step_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (match x with + | GOTO a0 -> Obj.magic (fun _ dH -> dH __) + | RETURN -> Obj.magic (fun _ dH -> dH) + | TAILCALL (a10, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val fin_step_labels : + unserialized_params -> joint_fin_step -> Graphs.label List.list **) +let fin_step_labels p = function +| GOTO l -> List.Cons (l, List.Nil) +| RETURN -> List.Nil +| TAILCALL (x0, x1) -> List.Nil + +type joint_statement = +| Sequential of joint_step * __ +| Final of joint_fin_step +| FCOND of __ * Graphs.label * Graphs.label + +(** val joint_statement_rect_Type4 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 **) +let rec joint_statement_rect_Type4 p globals h_sequential h_final h_FCOND = function +| Sequential (x_17852, x_17851) -> h_sequential x_17852 x_17851 +| Final x_17853 -> h_final x_17853 +| FCOND (x_17856, x_17855, x_17854) -> h_FCOND __ x_17856 x_17855 x_17854 + +(** val joint_statement_rect_Type5 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 **) +let rec joint_statement_rect_Type5 p globals h_sequential h_final h_FCOND = function +| Sequential (x_17863, x_17862) -> h_sequential x_17863 x_17862 +| Final x_17864 -> h_final x_17864 +| FCOND (x_17867, x_17866, x_17865) -> h_FCOND __ x_17867 x_17866 x_17865 + +(** val joint_statement_rect_Type3 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 **) +let rec joint_statement_rect_Type3 p globals h_sequential h_final h_FCOND = function +| Sequential (x_17874, x_17873) -> h_sequential x_17874 x_17873 +| Final x_17875 -> h_final x_17875 +| FCOND (x_17878, x_17877, x_17876) -> h_FCOND __ x_17878 x_17877 x_17876 + +(** val joint_statement_rect_Type2 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 **) +let rec joint_statement_rect_Type2 p globals h_sequential h_final h_FCOND = function +| Sequential (x_17885, x_17884) -> h_sequential x_17885 x_17884 +| Final x_17886 -> h_final x_17886 +| FCOND (x_17889, x_17888, x_17887) -> h_FCOND __ x_17889 x_17888 x_17887 + +(** val joint_statement_rect_Type1 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 **) +let rec joint_statement_rect_Type1 p globals h_sequential h_final h_FCOND = function +| Sequential (x_17896, x_17895) -> h_sequential x_17896 x_17895 +| Final x_17897 -> h_final x_17897 +| FCOND (x_17900, x_17899, x_17898) -> h_FCOND __ x_17900 x_17899 x_17898 + +(** val joint_statement_rect_Type0 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 **) +let rec joint_statement_rect_Type0 p globals h_sequential h_final h_FCOND = function +| Sequential (x_17907, x_17906) -> h_sequential x_17907 x_17906 +| Final x_17908 -> h_final x_17908 +| FCOND (x_17911, x_17910, x_17909) -> h_FCOND __ x_17911 x_17910 x_17909 + +(** val joint_statement_inv_rect_Type4 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> + __ -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> 'a1 **) +let joint_statement_inv_rect_Type4 x1 x2 hterm h1 h2 h3 = + let hcut = joint_statement_rect_Type4 x1 x2 h1 h2 h3 hterm in hcut __ + +(** val joint_statement_inv_rect_Type3 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> + __ -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> 'a1 **) +let joint_statement_inv_rect_Type3 x1 x2 hterm h1 h2 h3 = + let hcut = joint_statement_rect_Type3 x1 x2 h1 h2 h3 hterm in hcut __ + +(** val joint_statement_inv_rect_Type2 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> + __ -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> 'a1 **) +let joint_statement_inv_rect_Type2 x1 x2 hterm h1 h2 h3 = + let hcut = joint_statement_rect_Type2 x1 x2 h1 h2 h3 hterm in hcut __ + +(** val joint_statement_inv_rect_Type1 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> + __ -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> 'a1 **) +let joint_statement_inv_rect_Type1 x1 x2 hterm h1 h2 h3 = + let hcut = joint_statement_rect_Type1 x1 x2 h1 h2 h3 hterm in hcut __ + +(** val joint_statement_inv_rect_Type0 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> + __ -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> 'a1 **) +let joint_statement_inv_rect_Type0 x1 x2 hterm h1 h2 h3 = + let hcut = joint_statement_rect_Type0 x1 x2 h1 h2 h3 hterm in hcut __ + +(** val joint_statement_discr : + stmt_params -> AST.ident List.list -> joint_statement -> joint_statement + -> __ **) +let joint_statement_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Sequential (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Final a0 -> Obj.magic (fun _ dH -> dH __) + | FCOND (a10, a20, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val joint_statement_jmdiscr : + stmt_params -> AST.ident List.list -> joint_statement -> joint_statement + -> __ **) +let joint_statement_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Sequential (a0, a10) -> Obj.magic (fun _ dH -> dH __ __) + | Final a0 -> Obj.magic (fun _ dH -> dH __) + | FCOND (a10, a20, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val dpi1__o__fin_step_to_stmt__o__inject : + stmt_params -> AST.ident List.list -> (joint_fin_step, 'a1) Types.dPair + -> joint_statement Types.sig0 **) +let dpi1__o__fin_step_to_stmt__o__inject x0 x1 x4 = + Final x4.Types.dpi1 + +(** val eject__o__fin_step_to_stmt__o__inject : + stmt_params -> AST.ident List.list -> joint_fin_step Types.sig0 -> + joint_statement Types.sig0 **) +let eject__o__fin_step_to_stmt__o__inject x0 x1 x4 = + Final (Types.pi1 x4) + +(** val fin_step_to_stmt__o__inject : + stmt_params -> AST.ident List.list -> joint_fin_step -> joint_statement + Types.sig0 **) +let fin_step_to_stmt__o__inject x0 x1 x3 = + Final x3 + +(** val dpi1__o__fin_step_to_stmt : + stmt_params -> AST.ident List.list -> (joint_fin_step, 'a1) Types.dPair + -> joint_statement **) +let dpi1__o__fin_step_to_stmt x0 x1 x3 = + Final x3.Types.dpi1 + +(** val eject__o__fin_step_to_stmt : + stmt_params -> AST.ident List.list -> joint_fin_step Types.sig0 -> + joint_statement **) +let eject__o__fin_step_to_stmt x0 x1 x3 = + Final (Types.pi1 x3) + +type params = { stmt_pars : stmt_params; + stmt_at : (AST.ident List.list -> __ -> __ -> joint_statement + Types.option); + point_of_label : (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option); + point_of_succ : (__ -> __ -> __) } + +(** val params_rect_Type4 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> + 'a1 **) +let rec params_rect_Type4 h_mk_params x_17984 = + let { stmt_pars = stmt_pars0; stmt_at = stmt_at0; point_of_label = + point_of_label0; point_of_succ = point_of_succ0 } = x_17984 + in + h_mk_params stmt_pars0 __ __ stmt_at0 point_of_label0 point_of_succ0 + +(** val params_rect_Type5 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> + 'a1 **) +let rec params_rect_Type5 h_mk_params x_17986 = + let { stmt_pars = stmt_pars0; stmt_at = stmt_at0; point_of_label = + point_of_label0; point_of_succ = point_of_succ0 } = x_17986 + in + h_mk_params stmt_pars0 __ __ stmt_at0 point_of_label0 point_of_succ0 + +(** val params_rect_Type3 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> + 'a1 **) +let rec params_rect_Type3 h_mk_params x_17988 = + let { stmt_pars = stmt_pars0; stmt_at = stmt_at0; point_of_label = + point_of_label0; point_of_succ = point_of_succ0 } = x_17988 + in + h_mk_params stmt_pars0 __ __ stmt_at0 point_of_label0 point_of_succ0 + +(** val params_rect_Type2 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> + 'a1 **) +let rec params_rect_Type2 h_mk_params x_17990 = + let { stmt_pars = stmt_pars0; stmt_at = stmt_at0; point_of_label = + point_of_label0; point_of_succ = point_of_succ0 } = x_17990 + in + h_mk_params stmt_pars0 __ __ stmt_at0 point_of_label0 point_of_succ0 + +(** val params_rect_Type1 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> + 'a1 **) +let rec params_rect_Type1 h_mk_params x_17992 = + let { stmt_pars = stmt_pars0; stmt_at = stmt_at0; point_of_label = + point_of_label0; point_of_succ = point_of_succ0 } = x_17992 + in + h_mk_params stmt_pars0 __ __ stmt_at0 point_of_label0 point_of_succ0 + +(** val params_rect_Type0 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> + 'a1 **) +let rec params_rect_Type0 h_mk_params x_17994 = + let { stmt_pars = stmt_pars0; stmt_at = stmt_at0; point_of_label = + point_of_label0; point_of_succ = point_of_succ0 } = x_17994 + in + h_mk_params stmt_pars0 __ __ stmt_at0 point_of_label0 point_of_succ0 + +(** val stmt_pars : params -> stmt_params **) +let rec stmt_pars xxx = + xxx.stmt_pars + +type codeT = __ + +type code_point = __ + +(** val stmt_at : + params -> AST.ident List.list -> __ -> __ -> joint_statement Types.option **) +let rec stmt_at xxx = + xxx.stmt_at + +(** val point_of_label : + params -> AST.ident List.list -> __ -> Graphs.label -> __ Types.option **) +let rec point_of_label xxx = + xxx.point_of_label + +(** val point_of_succ : params -> __ -> __ -> __ **) +let rec point_of_succ xxx = + xxx.point_of_succ + +(** val params_inv_rect_Type4 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 **) +let params_inv_rect_Type4 hterm h1 = + let hcut = params_rect_Type4 h1 hterm in hcut __ + +(** val params_inv_rect_Type3 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 **) +let params_inv_rect_Type3 hterm h1 = + let hcut = params_rect_Type3 h1 hterm in hcut __ + +(** val params_inv_rect_Type2 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 **) +let params_inv_rect_Type2 hterm h1 = + let hcut = params_rect_Type2 h1 hterm in hcut __ + +(** val params_inv_rect_Type1 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 **) +let params_inv_rect_Type1 hterm h1 = + let hcut = params_rect_Type1 h1 hterm in hcut __ + +(** val params_inv_rect_Type0 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> + Graphs.label -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 **) +let params_inv_rect_Type0 hterm h1 = + let hcut = params_rect_Type0 h1 hterm in hcut __ + +(** val params_jmdiscr : params -> params -> __ **) +let params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { stmt_pars = a0; stmt_at = a3; point_of_label = a4; point_of_succ = + a5 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val stmt_pars__o__uns_pars : params -> uns_params **) +let stmt_pars__o__uns_pars x0 = + x0.stmt_pars.uns_pars + +(** val stmt_pars__o__uns_pars__o__u_pars : params -> unserialized_params **) +let stmt_pars__o__uns_pars__o__u_pars x0 = + uns_pars__o__u_pars x0.stmt_pars + +(** val code_has_point : + params -> AST.ident List.list -> __ -> __ -> Bool.bool **) +let code_has_point p globals c pt = + match p.stmt_at globals c pt with + | Types.None -> Bool.False + | Types.Some x -> Bool.True + +(** val code_has_label : + params -> AST.ident List.list -> __ -> Graphs.label -> Bool.bool **) +let code_has_label p globals c l = + match p.point_of_label globals c l with + | Types.None -> Bool.False + | Types.Some pt -> code_has_point p globals c pt + +(** val stmt_explicit_labels : + stmt_params -> AST.ident List.list -> joint_statement -> Graphs.label + List.list **) +let stmt_explicit_labels p globals = function +| Sequential (c, x) -> step_labels (uns_pars__o__u_pars p) globals c +| Final c -> fin_step_labels (uns_pars__o__u_pars p) c +| FCOND (x0, l1, l2) -> List.Cons (l1, (List.Cons (l2, List.Nil))) + +(** val stmt_implicit_label : + stmt_params -> AST.ident List.list -> joint_statement -> Graphs.label + Types.option **) +let stmt_implicit_label p globals = function +| Sequential (x, s0) -> p.succ_label s0 +| Final x -> Types.None +| FCOND (x0, x1, x2) -> Types.None + +(** val stmt_labels : + stmt_params -> AST.ident List.list -> joint_statement -> Graphs.label + List.list **) +let stmt_labels p g stmt = + List.append + (match stmt_implicit_label p g stmt with + | Types.None -> List.Nil + | Types.Some l -> List.Cons (l, List.Nil)) + (stmt_explicit_labels p g stmt) + +(** val stmt_registers : + stmt_params -> AST.ident List.list -> joint_statement -> + Registers.register List.list **) +let stmt_registers p globals = function +| Sequential (c, x) -> + get_used_registers_from_step p.uns_pars.u_pars globals p.uns_pars.functs c +| Final c -> + (match c with + | GOTO x -> List.Nil + | RETURN -> List.Nil + | TAILCALL (x0, r) -> p.uns_pars.functs.f_call_args r) +| FCOND (r, x0, x1) -> p.uns_pars.functs.acc_a_regs r + +type lin_params = + uns_params + (* singleton inductive, whose constructor was mk_lin_params *) + +(** val lin_params_rect_Type4 : (uns_params -> 'a1) -> lin_params -> 'a1 **) +let rec lin_params_rect_Type4 h_mk_lin_params x_18017 = + let l_u_pars = x_18017 in h_mk_lin_params l_u_pars + +(** val lin_params_rect_Type5 : (uns_params -> 'a1) -> lin_params -> 'a1 **) +let rec lin_params_rect_Type5 h_mk_lin_params x_18019 = + let l_u_pars = x_18019 in h_mk_lin_params l_u_pars + +(** val lin_params_rect_Type3 : (uns_params -> 'a1) -> lin_params -> 'a1 **) +let rec lin_params_rect_Type3 h_mk_lin_params x_18021 = + let l_u_pars = x_18021 in h_mk_lin_params l_u_pars + +(** val lin_params_rect_Type2 : (uns_params -> 'a1) -> lin_params -> 'a1 **) +let rec lin_params_rect_Type2 h_mk_lin_params x_18023 = + let l_u_pars = x_18023 in h_mk_lin_params l_u_pars + +(** val lin_params_rect_Type1 : (uns_params -> 'a1) -> lin_params -> 'a1 **) +let rec lin_params_rect_Type1 h_mk_lin_params x_18025 = + let l_u_pars = x_18025 in h_mk_lin_params l_u_pars + +(** val lin_params_rect_Type0 : (uns_params -> 'a1) -> lin_params -> 'a1 **) +let rec lin_params_rect_Type0 h_mk_lin_params x_18027 = + let l_u_pars = x_18027 in h_mk_lin_params l_u_pars + +(** val l_u_pars : lin_params -> uns_params **) +let rec l_u_pars xxx = + let yyy = xxx in yyy + +(** val lin_params_inv_rect_Type4 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let lin_params_inv_rect_Type4 hterm h1 = + let hcut = lin_params_rect_Type4 h1 hterm in hcut __ + +(** val lin_params_inv_rect_Type3 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let lin_params_inv_rect_Type3 hterm h1 = + let hcut = lin_params_rect_Type3 h1 hterm in hcut __ + +(** val lin_params_inv_rect_Type2 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let lin_params_inv_rect_Type2 hterm h1 = + let hcut = lin_params_rect_Type2 h1 hterm in hcut __ + +(** val lin_params_inv_rect_Type1 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let lin_params_inv_rect_Type1 hterm h1 = + let hcut = lin_params_rect_Type1 h1 hterm in hcut __ + +(** val lin_params_inv_rect_Type0 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let lin_params_inv_rect_Type0 hterm h1 = + let hcut = lin_params_rect_Type0 h1 hterm in hcut __ + +(** val lin_params_jmdiscr : lin_params -> lin_params -> __ **) +let lin_params_jmdiscr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val lin_params_to_params : lin_params -> params **) +let lin_params_to_params lp = + { stmt_pars = { uns_pars = (l_u_pars lp); succ_label = (fun x -> + Types.None); has_fcond = Bool.True }; stmt_at = + (fun globals code point -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Option.option) + (Obj.magic (List.nth_opt (Obj.magic point) (Obj.magic code))) + (fun ls -> + Monad.m_return0 (Monad.max_def Option.option) ls.Types.snd))); + point_of_label = (fun globals c lbl -> + Util.if_then_else_safe + (LabelledObjects.occurs_exactly_once PreIdentifiers.LabelTag lbl + (Obj.magic c)) (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def Option.option) + (LabelledObjects.index_of_label PreIdentifiers.LabelTag lbl + (Obj.magic c)))) (fun _ -> Types.None)); point_of_succ = + (fun current x -> Obj.magic (Nat.S (Obj.magic current))) } + +(** val lp_to_p__o__stmt_pars : lin_params -> stmt_params **) +let lp_to_p__o__stmt_pars x0 = + (lin_params_to_params x0).stmt_pars + +(** val lp_to_p__o__stmt_pars__o__uns_pars : lin_params -> uns_params **) +let lp_to_p__o__stmt_pars__o__uns_pars x0 = + stmt_pars__o__uns_pars (lin_params_to_params x0) + +(** val lp_to_p__o__stmt_pars__o__uns_pars__o__u_pars : + lin_params -> unserialized_params **) +let lp_to_p__o__stmt_pars__o__uns_pars__o__u_pars x0 = + stmt_pars__o__uns_pars__o__u_pars (lin_params_to_params x0) + +type graph_params = + uns_params + (* singleton inductive, whose constructor was mk_graph_params *) + +(** val graph_params_rect_Type4 : + (uns_params -> 'a1) -> graph_params -> 'a1 **) +let rec graph_params_rect_Type4 h_mk_graph_params x_18043 = + let g_u_pars = x_18043 in h_mk_graph_params g_u_pars + +(** val graph_params_rect_Type5 : + (uns_params -> 'a1) -> graph_params -> 'a1 **) +let rec graph_params_rect_Type5 h_mk_graph_params x_18045 = + let g_u_pars = x_18045 in h_mk_graph_params g_u_pars + +(** val graph_params_rect_Type3 : + (uns_params -> 'a1) -> graph_params -> 'a1 **) +let rec graph_params_rect_Type3 h_mk_graph_params x_18047 = + let g_u_pars = x_18047 in h_mk_graph_params g_u_pars + +(** val graph_params_rect_Type2 : + (uns_params -> 'a1) -> graph_params -> 'a1 **) +let rec graph_params_rect_Type2 h_mk_graph_params x_18049 = + let g_u_pars = x_18049 in h_mk_graph_params g_u_pars + +(** val graph_params_rect_Type1 : + (uns_params -> 'a1) -> graph_params -> 'a1 **) +let rec graph_params_rect_Type1 h_mk_graph_params x_18051 = + let g_u_pars = x_18051 in h_mk_graph_params g_u_pars + +(** val graph_params_rect_Type0 : + (uns_params -> 'a1) -> graph_params -> 'a1 **) +let rec graph_params_rect_Type0 h_mk_graph_params x_18053 = + let g_u_pars = x_18053 in h_mk_graph_params g_u_pars + +(** val g_u_pars : graph_params -> uns_params **) +let rec g_u_pars xxx = + let yyy = xxx in yyy + +(** val graph_params_inv_rect_Type4 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let graph_params_inv_rect_Type4 hterm h1 = + let hcut = graph_params_rect_Type4 h1 hterm in hcut __ + +(** val graph_params_inv_rect_Type3 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let graph_params_inv_rect_Type3 hterm h1 = + let hcut = graph_params_rect_Type3 h1 hterm in hcut __ + +(** val graph_params_inv_rect_Type2 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let graph_params_inv_rect_Type2 hterm h1 = + let hcut = graph_params_rect_Type2 h1 hterm in hcut __ + +(** val graph_params_inv_rect_Type1 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let graph_params_inv_rect_Type1 hterm h1 = + let hcut = graph_params_rect_Type1 h1 hterm in hcut __ + +(** val graph_params_inv_rect_Type0 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 **) +let graph_params_inv_rect_Type0 hterm h1 = + let hcut = graph_params_rect_Type0 h1 hterm in hcut __ + +(** val graph_params_jmdiscr : graph_params -> graph_params -> __ **) +let graph_params_jmdiscr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val graph_params_to_params : graph_params -> params **) +let graph_params_to_params gp = + { stmt_pars = { uns_pars = (g_u_pars gp); succ_label = + (Obj.magic (fun x -> Types.Some x)); has_fcond = Bool.False }; stmt_at = + (fun globals code -> + Obj.magic (Identifiers.lookup PreIdentifiers.LabelTag (Obj.magic code))); + point_of_label = (fun x x0 lbl -> + Obj.magic (Monad.m_return0 (Monad.max_def Option.option) lbl)); + point_of_succ = (fun x lbl -> lbl) } + +(** val gp_to_p__o__stmt_pars : graph_params -> stmt_params **) +let gp_to_p__o__stmt_pars x0 = + (graph_params_to_params x0).stmt_pars + +(** val gp_to_p__o__stmt_pars__o__uns_pars : graph_params -> uns_params **) +let gp_to_p__o__stmt_pars__o__uns_pars x0 = + stmt_pars__o__uns_pars (graph_params_to_params x0) + +(** val gp_to_p__o__stmt_pars__o__uns_pars__o__u_pars : + graph_params -> unserialized_params **) +let gp_to_p__o__stmt_pars__o__uns_pars__o__u_pars x0 = + stmt_pars__o__uns_pars__o__u_pars (graph_params_to_params x0) + +type joint_internal_function = { joint_if_luniverse : Identifiers.universe; + joint_if_runiverse : Identifiers.universe; + joint_if_result : __; joint_if_params : + __; joint_if_stacksize : Nat.nat; + joint_if_local_stacksize : Nat.nat; + joint_if_code : __; joint_if_entry : + __ } + +(** val joint_internal_function_rect_Type4 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> + 'a1) -> joint_internal_function -> 'a1 **) +let rec joint_internal_function_rect_Type4 p globals h_mk_joint_internal_function x_18069 = + let { joint_if_luniverse = joint_if_luniverse0; joint_if_runiverse = + joint_if_runiverse0; joint_if_result = joint_if_result0; + joint_if_params = joint_if_params0; joint_if_stacksize = + joint_if_stacksize0; joint_if_local_stacksize = + joint_if_local_stacksize0; joint_if_code = joint_if_code0; + joint_if_entry = joint_if_entry0 } = x_18069 + in + h_mk_joint_internal_function joint_if_luniverse0 joint_if_runiverse0 + joint_if_result0 joint_if_params0 joint_if_stacksize0 + joint_if_local_stacksize0 joint_if_code0 joint_if_entry0 + +(** val joint_internal_function_rect_Type5 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> + 'a1) -> joint_internal_function -> 'a1 **) +let rec joint_internal_function_rect_Type5 p globals h_mk_joint_internal_function x_18071 = + let { joint_if_luniverse = joint_if_luniverse0; joint_if_runiverse = + joint_if_runiverse0; joint_if_result = joint_if_result0; + joint_if_params = joint_if_params0; joint_if_stacksize = + joint_if_stacksize0; joint_if_local_stacksize = + joint_if_local_stacksize0; joint_if_code = joint_if_code0; + joint_if_entry = joint_if_entry0 } = x_18071 + in + h_mk_joint_internal_function joint_if_luniverse0 joint_if_runiverse0 + joint_if_result0 joint_if_params0 joint_if_stacksize0 + joint_if_local_stacksize0 joint_if_code0 joint_if_entry0 + +(** val joint_internal_function_rect_Type3 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> + 'a1) -> joint_internal_function -> 'a1 **) +let rec joint_internal_function_rect_Type3 p globals h_mk_joint_internal_function x_18073 = + let { joint_if_luniverse = joint_if_luniverse0; joint_if_runiverse = + joint_if_runiverse0; joint_if_result = joint_if_result0; + joint_if_params = joint_if_params0; joint_if_stacksize = + joint_if_stacksize0; joint_if_local_stacksize = + joint_if_local_stacksize0; joint_if_code = joint_if_code0; + joint_if_entry = joint_if_entry0 } = x_18073 + in + h_mk_joint_internal_function joint_if_luniverse0 joint_if_runiverse0 + joint_if_result0 joint_if_params0 joint_if_stacksize0 + joint_if_local_stacksize0 joint_if_code0 joint_if_entry0 + +(** val joint_internal_function_rect_Type2 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> + 'a1) -> joint_internal_function -> 'a1 **) +let rec joint_internal_function_rect_Type2 p globals h_mk_joint_internal_function x_18075 = + let { joint_if_luniverse = joint_if_luniverse0; joint_if_runiverse = + joint_if_runiverse0; joint_if_result = joint_if_result0; + joint_if_params = joint_if_params0; joint_if_stacksize = + joint_if_stacksize0; joint_if_local_stacksize = + joint_if_local_stacksize0; joint_if_code = joint_if_code0; + joint_if_entry = joint_if_entry0 } = x_18075 + in + h_mk_joint_internal_function joint_if_luniverse0 joint_if_runiverse0 + joint_if_result0 joint_if_params0 joint_if_stacksize0 + joint_if_local_stacksize0 joint_if_code0 joint_if_entry0 + +(** val joint_internal_function_rect_Type1 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> + 'a1) -> joint_internal_function -> 'a1 **) +let rec joint_internal_function_rect_Type1 p globals h_mk_joint_internal_function x_18077 = + let { joint_if_luniverse = joint_if_luniverse0; joint_if_runiverse = + joint_if_runiverse0; joint_if_result = joint_if_result0; + joint_if_params = joint_if_params0; joint_if_stacksize = + joint_if_stacksize0; joint_if_local_stacksize = + joint_if_local_stacksize0; joint_if_code = joint_if_code0; + joint_if_entry = joint_if_entry0 } = x_18077 + in + h_mk_joint_internal_function joint_if_luniverse0 joint_if_runiverse0 + joint_if_result0 joint_if_params0 joint_if_stacksize0 + joint_if_local_stacksize0 joint_if_code0 joint_if_entry0 + +(** val joint_internal_function_rect_Type0 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> + 'a1) -> joint_internal_function -> 'a1 **) +let rec joint_internal_function_rect_Type0 p globals h_mk_joint_internal_function x_18079 = + let { joint_if_luniverse = joint_if_luniverse0; joint_if_runiverse = + joint_if_runiverse0; joint_if_result = joint_if_result0; + joint_if_params = joint_if_params0; joint_if_stacksize = + joint_if_stacksize0; joint_if_local_stacksize = + joint_if_local_stacksize0; joint_if_code = joint_if_code0; + joint_if_entry = joint_if_entry0 } = x_18079 + in + h_mk_joint_internal_function joint_if_luniverse0 joint_if_runiverse0 + joint_if_result0 joint_if_params0 joint_if_stacksize0 + joint_if_local_stacksize0 joint_if_code0 joint_if_entry0 + +(** val joint_if_luniverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe **) +let rec joint_if_luniverse p globals xxx = + xxx.joint_if_luniverse + +(** val joint_if_runiverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe **) +let rec joint_if_runiverse p globals xxx = + xxx.joint_if_runiverse + +(** val joint_if_result : + params -> AST.ident List.list -> joint_internal_function -> __ **) +let rec joint_if_result p globals xxx = + xxx.joint_if_result + +(** val joint_if_params : + params -> AST.ident List.list -> joint_internal_function -> __ **) +let rec joint_if_params p globals xxx = + xxx.joint_if_params + +(** val joint_if_stacksize : + params -> AST.ident List.list -> joint_internal_function -> Nat.nat **) +let rec joint_if_stacksize p globals xxx = + xxx.joint_if_stacksize + +(** val joint_if_local_stacksize : + params -> AST.ident List.list -> joint_internal_function -> Nat.nat **) +let rec joint_if_local_stacksize p globals xxx = + xxx.joint_if_local_stacksize + +(** val joint_if_code : + params -> AST.ident List.list -> joint_internal_function -> __ **) +let rec joint_if_code p globals xxx = + xxx.joint_if_code + +(** val joint_if_entry : + params -> AST.ident List.list -> joint_internal_function -> __ **) +let rec joint_if_entry p globals xxx = + xxx.joint_if_entry + +(** val joint_internal_function_inv_rect_Type4 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let joint_internal_function_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = joint_internal_function_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val joint_internal_function_inv_rect_Type3 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let joint_internal_function_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = joint_internal_function_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val joint_internal_function_inv_rect_Type2 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let joint_internal_function_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = joint_internal_function_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val joint_internal_function_inv_rect_Type1 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let joint_internal_function_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = joint_internal_function_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val joint_internal_function_inv_rect_Type0 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let joint_internal_function_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = joint_internal_function_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val joint_internal_function_jmdiscr : + params -> AST.ident List.list -> joint_internal_function -> + joint_internal_function -> __ **) +let joint_internal_function_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (let { joint_if_luniverse = a0; joint_if_runiverse = a10; + joint_if_result = a20; joint_if_params = a3; joint_if_stacksize = a4; + joint_if_local_stacksize = a5; joint_if_code = a6; joint_if_entry = + a7 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __)) y + +(** val good_if_rect_Type4 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec good_if_rect_Type4 p globals def h_mk_good_if = + h_mk_good_if __ __ __ __ __ + +(** val good_if_rect_Type5 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec good_if_rect_Type5 p globals def h_mk_good_if = + h_mk_good_if __ __ __ __ __ + +(** val good_if_rect_Type3 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec good_if_rect_Type3 p globals def h_mk_good_if = + h_mk_good_if __ __ __ __ __ + +(** val good_if_rect_Type2 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec good_if_rect_Type2 p globals def h_mk_good_if = + h_mk_good_if __ __ __ __ __ + +(** val good_if_rect_Type1 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec good_if_rect_Type1 p globals def h_mk_good_if = + h_mk_good_if __ __ __ __ __ + +(** val good_if_rect_Type0 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec good_if_rect_Type0 p globals def h_mk_good_if = + h_mk_good_if __ __ __ __ __ + +(** val good_if_inv_rect_Type4 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let good_if_inv_rect_Type4 x1 x2 x3 h1 = + let hcut = good_if_rect_Type4 x1 x2 x3 h1 in hcut __ + +(** val good_if_inv_rect_Type3 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let good_if_inv_rect_Type3 x1 x2 x3 h1 = + let hcut = good_if_rect_Type3 x1 x2 x3 h1 in hcut __ + +(** val good_if_inv_rect_Type2 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let good_if_inv_rect_Type2 x1 x2 x3 h1 = + let hcut = good_if_rect_Type2 x1 x2 x3 h1 in hcut __ + +(** val good_if_inv_rect_Type1 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let good_if_inv_rect_Type1 x1 x2 x3 h1 = + let hcut = good_if_rect_Type1 x1 x2 x3 h1 in hcut __ + +(** val good_if_inv_rect_Type0 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let good_if_inv_rect_Type0 x1 x2 x3 h1 = + let hcut = good_if_rect_Type0 x1 x2 x3 h1 in hcut __ + +(** val good_if_discr : + params -> AST.ident List.list -> joint_internal_function -> __ **) +let good_if_discr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __ __ __)) __ + +(** val good_if_jmdiscr : + params -> AST.ident List.list -> joint_internal_function -> __ **) +let good_if_jmdiscr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __ __ __)) __ + +type joint_closed_internal_function = joint_internal_function Types.sig0 + +(** val set_joint_code : + AST.ident List.list -> params -> joint_internal_function -> __ -> __ -> + joint_internal_function **) +let set_joint_code globals pars int_fun graph entry = + { joint_if_luniverse = int_fun.joint_if_luniverse; joint_if_runiverse = + int_fun.joint_if_runiverse; joint_if_result = int_fun.joint_if_result; + joint_if_params = int_fun.joint_if_params; joint_if_stacksize = + int_fun.joint_if_stacksize; joint_if_local_stacksize = + int_fun.joint_if_local_stacksize; joint_if_code = graph; joint_if_entry = + entry } + +(** val set_luniverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe -> joint_internal_function **) +let set_luniverse globals pars p luniverse = + { joint_if_luniverse = luniverse; joint_if_runiverse = + p.joint_if_runiverse; joint_if_result = p.joint_if_result; + joint_if_params = p.joint_if_params; joint_if_stacksize = + p.joint_if_stacksize; joint_if_local_stacksize = + p.joint_if_local_stacksize; joint_if_code = p.joint_if_code; + joint_if_entry = p.joint_if_entry } + +(** val set_runiverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe -> joint_internal_function **) +let set_runiverse globals pars p runiverse = + { joint_if_luniverse = p.joint_if_luniverse; joint_if_runiverse = + runiverse; joint_if_result = p.joint_if_result; joint_if_params = + p.joint_if_params; joint_if_stacksize = p.joint_if_stacksize; + joint_if_local_stacksize = p.joint_if_local_stacksize; joint_if_code = + p.joint_if_code; joint_if_entry = p.joint_if_entry } + +(** val add_graph : + graph_params -> AST.ident List.list -> Graphs.label -> joint_statement -> + joint_internal_function -> joint_internal_function **) +let add_graph g_pars globals l stmt p = + let code = + Identifiers.add PreIdentifiers.LabelTag (Obj.magic p.joint_if_code) l + stmt + in + { joint_if_luniverse = p.joint_if_luniverse; joint_if_runiverse = + p.joint_if_runiverse; joint_if_result = p.joint_if_result; + joint_if_params = p.joint_if_params; joint_if_stacksize = + p.joint_if_stacksize; joint_if_local_stacksize = + p.joint_if_local_stacksize; joint_if_code = (Obj.magic code); + joint_if_entry = p.joint_if_entry } + +type joint_function = joint_closed_internal_function AST.fundef + +type joint_program = { jp_functions : AST.ident List.list; + joint_prog : (joint_function, AST.init_data List.list) + AST.program; + init_cost_label : CostLabel.costlabel } + +(** val joint_program_rect_Type4 : + params -> (AST.ident List.list -> (joint_function, AST.init_data + List.list) AST.program -> CostLabel.costlabel -> __ -> 'a1) -> + joint_program -> 'a1 **) +let rec joint_program_rect_Type4 p h_mk_joint_program x_18121 = + let { jp_functions = jp_functions0; joint_prog = joint_prog0; + init_cost_label = init_cost_label0 } = x_18121 + in + h_mk_joint_program jp_functions0 joint_prog0 init_cost_label0 __ + +(** val joint_program_rect_Type5 : + params -> (AST.ident List.list -> (joint_function, AST.init_data + List.list) AST.program -> CostLabel.costlabel -> __ -> 'a1) -> + joint_program -> 'a1 **) +let rec joint_program_rect_Type5 p h_mk_joint_program x_18123 = + let { jp_functions = jp_functions0; joint_prog = joint_prog0; + init_cost_label = init_cost_label0 } = x_18123 + in + h_mk_joint_program jp_functions0 joint_prog0 init_cost_label0 __ + +(** val joint_program_rect_Type3 : + params -> (AST.ident List.list -> (joint_function, AST.init_data + List.list) AST.program -> CostLabel.costlabel -> __ -> 'a1) -> + joint_program -> 'a1 **) +let rec joint_program_rect_Type3 p h_mk_joint_program x_18125 = + let { jp_functions = jp_functions0; joint_prog = joint_prog0; + init_cost_label = init_cost_label0 } = x_18125 + in + h_mk_joint_program jp_functions0 joint_prog0 init_cost_label0 __ + +(** val joint_program_rect_Type2 : + params -> (AST.ident List.list -> (joint_function, AST.init_data + List.list) AST.program -> CostLabel.costlabel -> __ -> 'a1) -> + joint_program -> 'a1 **) +let rec joint_program_rect_Type2 p h_mk_joint_program x_18127 = + let { jp_functions = jp_functions0; joint_prog = joint_prog0; + init_cost_label = init_cost_label0 } = x_18127 + in + h_mk_joint_program jp_functions0 joint_prog0 init_cost_label0 __ + +(** val joint_program_rect_Type1 : + params -> (AST.ident List.list -> (joint_function, AST.init_data + List.list) AST.program -> CostLabel.costlabel -> __ -> 'a1) -> + joint_program -> 'a1 **) +let rec joint_program_rect_Type1 p h_mk_joint_program x_18129 = + let { jp_functions = jp_functions0; joint_prog = joint_prog0; + init_cost_label = init_cost_label0 } = x_18129 + in + h_mk_joint_program jp_functions0 joint_prog0 init_cost_label0 __ + +(** val joint_program_rect_Type0 : + params -> (AST.ident List.list -> (joint_function, AST.init_data + List.list) AST.program -> CostLabel.costlabel -> __ -> 'a1) -> + joint_program -> 'a1 **) +let rec joint_program_rect_Type0 p h_mk_joint_program x_18131 = + let { jp_functions = jp_functions0; joint_prog = joint_prog0; + init_cost_label = init_cost_label0 } = x_18131 + in + h_mk_joint_program jp_functions0 joint_prog0 init_cost_label0 __ + +(** val jp_functions : params -> joint_program -> AST.ident List.list **) +let rec jp_functions p xxx = + xxx.jp_functions + +(** val joint_prog : + params -> joint_program -> (joint_function, AST.init_data List.list) + AST.program **) +let rec joint_prog p xxx = + xxx.joint_prog + +(** val init_cost_label : params -> joint_program -> CostLabel.costlabel **) +let rec init_cost_label p xxx = + xxx.init_cost_label + +(** val joint_program_inv_rect_Type4 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ + -> 'a1) -> 'a1 **) +let joint_program_inv_rect_Type4 x1 hterm h1 = + let hcut = joint_program_rect_Type4 x1 h1 hterm in hcut __ + +(** val joint_program_inv_rect_Type3 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ + -> 'a1) -> 'a1 **) +let joint_program_inv_rect_Type3 x1 hterm h1 = + let hcut = joint_program_rect_Type3 x1 h1 hterm in hcut __ + +(** val joint_program_inv_rect_Type2 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ + -> 'a1) -> 'a1 **) +let joint_program_inv_rect_Type2 x1 hterm h1 = + let hcut = joint_program_rect_Type2 x1 h1 hterm in hcut __ + +(** val joint_program_inv_rect_Type1 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ + -> 'a1) -> 'a1 **) +let joint_program_inv_rect_Type1 x1 hterm h1 = + let hcut = joint_program_rect_Type1 x1 h1 hterm in hcut __ + +(** val joint_program_inv_rect_Type0 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ + -> 'a1) -> 'a1 **) +let joint_program_inv_rect_Type0 x1 hterm h1 = + let hcut = joint_program_rect_Type0 x1 h1 hterm in hcut __ + +(** val joint_program_discr : + params -> joint_program -> joint_program -> __ **) +let joint_program_discr a1 x y = + Logic.eq_rect_Type2 x + (let { jp_functions = a0; joint_prog = a10; init_cost_label = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val joint_program_jmdiscr : + params -> joint_program -> joint_program -> __ **) +let joint_program_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { jp_functions = a0; joint_prog = a10; init_cost_label = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val dpi1__o__joint_prog__o__inject : + params -> (joint_program, 'a1) Types.dPair -> (joint_function, + AST.init_data List.list) AST.program Types.sig0 **) +let dpi1__o__joint_prog__o__inject x0 x2 = + x2.Types.dpi1.joint_prog + +(** val eject__o__joint_prog__o__inject : + params -> joint_program Types.sig0 -> (joint_function, AST.init_data + List.list) AST.program Types.sig0 **) +let eject__o__joint_prog__o__inject x0 x2 = + (Types.pi1 x2).joint_prog + +(** val joint_prog__o__inject : + params -> joint_program -> (joint_function, AST.init_data List.list) + AST.program Types.sig0 **) +let joint_prog__o__inject x0 x1 = + x1.joint_prog + +(** val dpi1__o__joint_prog : + params -> (joint_program, 'a1) Types.dPair -> (joint_function, + AST.init_data List.list) AST.program **) +let dpi1__o__joint_prog x0 x2 = + x2.Types.dpi1.joint_prog + +(** val eject__o__joint_prog : + params -> joint_program Types.sig0 -> (joint_function, AST.init_data + List.list) AST.program **) +let eject__o__joint_prog x0 x2 = + (Types.pi1 x2).joint_prog + +(** val prog_names : params -> joint_program -> AST.ident List.list **) +let prog_names pars p = + List.append (AST.prog_var_names p.joint_prog) p.jp_functions + +(** val transform_joint_program : + params -> params -> (AST.ident List.list -> + joint_closed_internal_function -> joint_closed_internal_function) -> + joint_program -> joint_program **) +let transform_joint_program src dst trans prog_in = + { jp_functions = prog_in.jp_functions; joint_prog = + (AST.transform_program prog_in.joint_prog (fun vars -> + AST.transf_fundef (trans (List.append vars prog_in.jp_functions)))); + init_cost_label = prog_in.init_cost_label } + +type stack_cost_model = (AST.ident, Nat.nat) Types.prod List.list + +(** val stack_cost : params -> joint_program -> stack_cost_model **) +let stack_cost p pr = + List.foldr (fun id_fun acc -> + let { Types.fst = id; Types.snd = fun0 } = id_fun in + (match fun0 with + | AST.Internal jif -> + List.Cons ({ Types.fst = id; Types.snd = + (Types.pi1 jif).joint_if_stacksize }, acc) + | AST.External x -> acc)) List.Nil pr.joint_prog.AST.prog_funct + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +(** val globals_stacksize : params -> joint_program -> Nat.nat **) +let globals_stacksize pars p = + List.fold Nat.plus Nat.O (fun entry -> Bool.True) (fun entry -> + Globalenvs.size_init_data_list entry.Types.snd) + p.joint_prog.AST.prog_vars + diff --git a/extracted/joint.mli b/extracted/joint.mli new file mode 100644 index 0000000..16bc0e9 --- /dev/null +++ b/extracted/joint.mli @@ -0,0 +1,1518 @@ +open Preamble + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open CostLabel + +open Order + +open Registers + +open I8051 + +open BitVectorTrie + +open Graphs + +open LabelledObjects + +open Sets + +open Listb + +open String + +type 't argument = +| Reg of 't +| Imm of BitVector.byte + +val argument_rect_Type4 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 + +val argument_rect_Type5 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 + +val argument_rect_Type3 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 + +val argument_rect_Type2 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 + +val argument_rect_Type1 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 + +val argument_rect_Type0 : + ('a1 -> 'a2) -> (BitVector.byte -> 'a2) -> 'a1 argument -> 'a2 + +val argument_inv_rect_Type4 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> 'a2 + +val argument_inv_rect_Type3 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> 'a2 + +val argument_inv_rect_Type2 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> 'a2 + +val argument_inv_rect_Type1 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> 'a2 + +val argument_inv_rect_Type0 : + 'a1 argument -> ('a1 -> __ -> 'a2) -> (BitVector.byte -> __ -> 'a2) -> 'a2 + +val argument_discr : 'a1 argument -> 'a1 argument -> __ + +val argument_jmdiscr : 'a1 argument -> 'a1 argument -> __ + +type psd_argument = Registers.register argument + +val psd_argument_from_reg : Registers.register -> psd_argument + +val dpi1__o__reg_to_psd_argument__o__inject : + (Registers.register, 'a1) Types.dPair -> psd_argument Types.sig0 + +val eject__o__reg_to_psd_argument__o__inject : + Registers.register Types.sig0 -> psd_argument Types.sig0 + +val reg_to_psd_argument__o__inject : + Registers.register -> psd_argument Types.sig0 + +val dpi1__o__reg_to_psd_argument : + (Registers.register, 'a1) Types.dPair -> psd_argument + +val eject__o__reg_to_psd_argument : + Registers.register Types.sig0 -> psd_argument + +val psd_argument_from_byte : BitVector.byte -> psd_argument + +val dpi1__o__byte_to_psd_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> psd_argument Types.sig0 + +val eject__o__byte_to_psd_argument__o__inject : + BitVector.byte Types.sig0 -> psd_argument Types.sig0 + +val byte_to_psd_argument__o__inject : + BitVector.byte -> psd_argument Types.sig0 + +val dpi1__o__byte_to_psd_argument : + (BitVector.byte, 'a1) Types.dPair -> psd_argument + +val eject__o__byte_to_psd_argument : + BitVector.byte Types.sig0 -> psd_argument + +type hdw_argument = I8051.register argument + +val hdw_argument_from_reg : I8051.register -> hdw_argument + +val dpi1__o__reg_to_hdw_argument__o__inject : + (I8051.register, 'a1) Types.dPair -> hdw_argument Types.sig0 + +val eject__o__reg_to_hdw_argument__o__inject : + I8051.register Types.sig0 -> hdw_argument Types.sig0 + +val reg_to_hdw_argument__o__inject : + I8051.register -> hdw_argument Types.sig0 + +val dpi1__o__reg_to_hdw_argument : + (I8051.register, 'a1) Types.dPair -> hdw_argument + +val eject__o__reg_to_hdw_argument : I8051.register Types.sig0 -> hdw_argument + +val hdw_argument_from_byte : BitVector.byte -> hdw_argument + +val dpi1__o__byte_to_hdw_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> psd_argument Types.sig0 + +val eject__o__byte_to_hdw_argument__o__inject : + BitVector.byte Types.sig0 -> psd_argument Types.sig0 + +val byte_to_hdw_argument__o__inject : + BitVector.byte -> psd_argument Types.sig0 + +val dpi1__o__byte_to_hdw_argument : + (BitVector.byte, 'a1) Types.dPair -> psd_argument + +val eject__o__byte_to_hdw_argument : + BitVector.byte Types.sig0 -> psd_argument + +val byte_of_nat : Nat.nat -> BitVector.byte + +val zero_byte : BitVector.byte + +type unserialized_params = { ext_seq_labels : (__ -> Graphs.label List.list); + has_tailcalls : Bool.bool } + +val unserialized_params_rect_Type4 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 + +val unserialized_params_rect_Type5 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 + +val unserialized_params_rect_Type3 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 + +val unserialized_params_rect_Type2 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 + +val unserialized_params_rect_Type1 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 + +val unserialized_params_rect_Type0 : + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> (__ -> Graphs.label List.list) -> Bool.bool -> __ -> 'a1) -> + unserialized_params -> 'a1 + +type acc_a_reg + +type acc_b_reg + +type acc_a_arg + +type acc_b_arg + +type dpl_reg + +type dph_reg + +type dpl_arg + +type dph_arg + +type snd_arg + +type pair_move + +type call_args + +type call_dest + +type ext_seq + +val ext_seq_labels : unserialized_params -> __ -> Graphs.label List.list + +val has_tailcalls : unserialized_params -> Bool.bool + +type paramsT + +val unserialized_params_inv_rect_Type4 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool -> + __ -> __ -> 'a1) -> 'a1 + +val unserialized_params_inv_rect_Type3 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool -> + __ -> __ -> 'a1) -> 'a1 + +val unserialized_params_inv_rect_Type2 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool -> + __ -> __ -> 'a1) -> 'a1 + +val unserialized_params_inv_rect_Type1 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool -> + __ -> __ -> 'a1) -> 'a1 + +val unserialized_params_inv_rect_Type0 : + unserialized_params -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> __ -> __ -> (__ -> Graphs.label List.list) -> Bool.bool -> + __ -> __ -> 'a1) -> 'a1 + +val unserialized_params_jmdiscr : + unserialized_params -> unserialized_params -> __ + +type get_pseudo_reg_functs = { acc_a_regs : (__ -> Registers.register + List.list); + acc_b_regs : (__ -> Registers.register + List.list); + acc_a_args : (__ -> Registers.register + List.list); + acc_b_args : (__ -> Registers.register + List.list); + dpl_regs : (__ -> Registers.register + List.list); + dph_regs : (__ -> Registers.register + List.list); + dpl_args : (__ -> Registers.register + List.list); + dph_args : (__ -> Registers.register + List.list); + snd_args : (__ -> Registers.register + List.list); + pair_move_regs : (__ -> Registers.register + List.list); + f_call_args : (__ -> Registers.register + List.list); + f_call_dest : (__ -> Registers.register + List.list); + ext_seq_regs : (__ -> Registers.register + List.list); + params_regs : (__ -> Registers.register + List.list) } + +val get_pseudo_reg_functs_rect_Type4 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 + +val get_pseudo_reg_functs_rect_Type5 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 + +val get_pseudo_reg_functs_rect_Type3 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 + +val get_pseudo_reg_functs_rect_Type2 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 + +val get_pseudo_reg_functs_rect_Type1 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 + +val get_pseudo_reg_functs_rect_Type0 : + unserialized_params -> ((__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> 'a1) -> get_pseudo_reg_functs -> + 'a1 + +val acc_a_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val acc_b_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val acc_a_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val acc_b_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val dpl_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val dph_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val dpl_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val dph_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val snd_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val pair_move_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val f_call_args : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val f_call_dest : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val ext_seq_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val params_regs : + unserialized_params -> get_pseudo_reg_functs -> __ -> Registers.register + List.list + +val get_pseudo_reg_functs_inv_rect_Type4 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> __ + -> 'a1) -> 'a1 + +val get_pseudo_reg_functs_inv_rect_Type3 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> __ + -> 'a1) -> 'a1 + +val get_pseudo_reg_functs_inv_rect_Type2 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> __ + -> 'a1) -> 'a1 + +val get_pseudo_reg_functs_inv_rect_Type1 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> __ + -> 'a1) -> 'a1 + +val get_pseudo_reg_functs_inv_rect_Type0 : + unserialized_params -> get_pseudo_reg_functs -> ((__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> + (__ -> Registers.register List.list) -> (__ -> Registers.register + List.list) -> (__ -> Registers.register List.list) -> (__ -> + Registers.register List.list) -> (__ -> Registers.register List.list) -> __ + -> 'a1) -> 'a1 + +val get_pseudo_reg_functs_jmdiscr : + unserialized_params -> get_pseudo_reg_functs -> get_pseudo_reg_functs -> __ + +type uns_params = { u_pars : unserialized_params; + functs : get_pseudo_reg_functs } + +val uns_params_rect_Type4 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> 'a1 + +val uns_params_rect_Type5 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> 'a1 + +val uns_params_rect_Type3 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> 'a1 + +val uns_params_rect_Type2 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> 'a1 + +val uns_params_rect_Type1 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> 'a1 + +val uns_params_rect_Type0 : + (unserialized_params -> get_pseudo_reg_functs -> 'a1) -> uns_params -> 'a1 + +val u_pars : uns_params -> unserialized_params + +val functs : uns_params -> get_pseudo_reg_functs + +val uns_params_inv_rect_Type4 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 + +val uns_params_inv_rect_Type3 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 + +val uns_params_inv_rect_Type2 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 + +val uns_params_inv_rect_Type1 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 + +val uns_params_inv_rect_Type0 : + uns_params -> (unserialized_params -> get_pseudo_reg_functs -> __ -> 'a1) + -> 'a1 + +val uns_params_jmdiscr : uns_params -> uns_params -> __ + +type joint_seq = +| COMMENT of String.string +| MOVE of __ +| POP of __ +| PUSH of __ +| ADDRESS of AST.ident * BitVector.word * __ * __ +| OPACCS of BackEndOps.opAccs * __ * __ * __ * __ +| OP1 of BackEndOps.op1 * __ * __ +| OP2 of BackEndOps.op2 * __ * __ * __ +| CLEAR_CARRY +| SET_CARRY +| LOAD of __ * __ * __ +| STORE of __ * __ * __ +| Extension_seq of __ + +val joint_seq_rect_Type4 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> BitVector.word + -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> 'a1) + -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ + -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> 'a1) + -> (__ -> 'a1) -> joint_seq -> 'a1 + +val joint_seq_rect_Type5 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> BitVector.word + -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> 'a1) + -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ + -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> 'a1) + -> (__ -> 'a1) -> joint_seq -> 'a1 + +val joint_seq_rect_Type3 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> BitVector.word + -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> 'a1) + -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ + -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> 'a1) + -> (__ -> 'a1) -> joint_seq -> 'a1 + +val joint_seq_rect_Type2 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> BitVector.word + -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> 'a1) + -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ + -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> 'a1) + -> (__ -> 'a1) -> joint_seq -> 'a1 + +val joint_seq_rect_Type1 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> BitVector.word + -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> 'a1) + -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ + -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> 'a1) + -> (__ -> 'a1) -> joint_seq -> 'a1 + +val joint_seq_rect_Type0 : + unserialized_params -> AST.ident List.list -> (String.string -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (AST.ident -> __ -> BitVector.word + -> __ -> __ -> 'a1) -> (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> 'a1) + -> (BackEndOps.op1 -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ + -> 'a1) -> 'a1 -> 'a1 -> (__ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> 'a1) + -> (__ -> 'a1) -> joint_seq -> 'a1 + +val joint_seq_inv_rect_Type4 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op1 + -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ + -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 + +val joint_seq_inv_rect_Type3 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op1 + -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ + -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 + +val joint_seq_inv_rect_Type2 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op1 + -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ + -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 + +val joint_seq_inv_rect_Type1 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op1 + -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ + -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 + +val joint_seq_inv_rect_Type0 : + unserialized_params -> AST.ident List.list -> joint_seq -> (String.string + -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> (__ -> __ -> + 'a1) -> (AST.ident -> __ -> BitVector.word -> __ -> __ -> __ -> 'a1) -> + (BackEndOps.opAccs -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op1 + -> __ -> __ -> __ -> 'a1) -> (BackEndOps.op2 -> __ -> __ -> __ -> __ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> 'a1) -> (__ + -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> 'a1) -> 'a1 + +val joint_seq_discr : + unserialized_params -> AST.ident List.list -> joint_seq -> joint_seq -> __ + +val joint_seq_jmdiscr : + unserialized_params -> AST.ident List.list -> joint_seq -> joint_seq -> __ + +val get_used_registers_from_seq : + unserialized_params -> AST.ident List.list -> get_pseudo_reg_functs -> + joint_seq -> Registers.register List.list + +val nOOP : unserialized_params -> AST.ident List.list -> joint_seq + +val dpi1__o__extension_seq_to_seq__o__inject : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_seq Types.sig0 + +val eject__o__extension_seq_to_seq__o__inject : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_seq + Types.sig0 + +val extension_seq_to_seq__o__inject : + unserialized_params -> AST.ident List.list -> __ -> joint_seq Types.sig0 + +val dpi1__o__extension_seq_to_seq : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_seq + +val eject__o__extension_seq_to_seq : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_seq + +type joint_step = +| COST_LABEL of CostLabel.costlabel +| CALL of (AST.ident, (__, __) Types.prod) Types.sum * __ * __ +| COND of __ * Graphs.label +| Step_seq of joint_seq + +val joint_step_rect_Type4 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> 'a1) + -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) -> (__ + -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 + +val joint_step_rect_Type5 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> 'a1) + -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) -> (__ + -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 + +val joint_step_rect_Type3 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> 'a1) + -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) -> (__ + -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 + +val joint_step_rect_Type2 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> 'a1) + -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) -> (__ + -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 + +val joint_step_rect_Type1 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> 'a1) + -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) -> (__ + -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 + +val joint_step_rect_Type0 : + unserialized_params -> AST.ident List.list -> (CostLabel.costlabel -> 'a1) + -> ((AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> 'a1) -> (__ + -> Graphs.label -> 'a1) -> (joint_seq -> 'a1) -> joint_step -> 'a1 + +val joint_step_inv_rect_Type4 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) -> + (joint_seq -> __ -> 'a1) -> 'a1 + +val joint_step_inv_rect_Type3 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) -> + (joint_seq -> __ -> 'a1) -> 'a1 + +val joint_step_inv_rect_Type2 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) -> + (joint_seq -> __ -> 'a1) -> 'a1 + +val joint_step_inv_rect_Type1 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) -> + (joint_seq -> __ -> 'a1) -> 'a1 + +val joint_step_inv_rect_Type0 : + unserialized_params -> AST.ident List.list -> joint_step -> + (CostLabel.costlabel -> __ -> 'a1) -> ((AST.ident, (__, __) Types.prod) + Types.sum -> __ -> __ -> __ -> 'a1) -> (__ -> Graphs.label -> __ -> 'a1) -> + (joint_seq -> __ -> 'a1) -> 'a1 + +val joint_step_discr : + unserialized_params -> AST.ident List.list -> joint_step -> joint_step -> + __ + +val joint_step_jmdiscr : + unserialized_params -> AST.ident List.list -> joint_step -> joint_step -> + __ + +val get_used_registers_from_step : + unserialized_params -> AST.ident List.list -> get_pseudo_reg_functs -> + joint_step -> Registers.register List.list + +val dpi1__o__extension_seq_to_seq__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_step Types.sig0 + +val eject__o__extension_seq_to_seq__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_step + Types.sig0 + +val extension_seq_to_seq__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> __ -> joint_step Types.sig0 + +val dpi1__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> (joint_seq, 'a1) Types.dPair + -> joint_step Types.sig0 + +val eject__o__seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> joint_seq Types.sig0 -> + joint_step Types.sig0 + +val seq_to_step__o__inject : + unserialized_params -> AST.ident List.list -> joint_seq -> joint_step + Types.sig0 + +val dpi1__o__extension_seq_to_seq__o__seq_to_step : + unserialized_params -> AST.ident List.list -> (__, 'a1) Types.dPair -> + joint_step + +val eject__o__extension_seq_to_seq__o__seq_to_step : + unserialized_params -> AST.ident List.list -> __ Types.sig0 -> joint_step + +val extension_seq_to_seq__o__seq_to_step : + unserialized_params -> AST.ident List.list -> __ -> joint_step + +val dpi1__o__seq_to_step : + unserialized_params -> AST.ident List.list -> (joint_seq, 'a1) Types.dPair + -> joint_step + +val eject__o__seq_to_step : + unserialized_params -> AST.ident List.list -> joint_seq Types.sig0 -> + joint_step + +val step_labels : + unserialized_params -> AST.ident List.list -> joint_step -> Graphs.label + List.list + +type stmt_params = { uns_pars : uns_params; + succ_label : (__ -> Graphs.label Types.option); + has_fcond : Bool.bool } + +val stmt_params_rect_Type4 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> 'a1) + -> stmt_params -> 'a1 + +val stmt_params_rect_Type5 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> 'a1) + -> stmt_params -> 'a1 + +val stmt_params_rect_Type3 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> 'a1) + -> stmt_params -> 'a1 + +val stmt_params_rect_Type2 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> 'a1) + -> stmt_params -> 'a1 + +val stmt_params_rect_Type1 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> 'a1) + -> stmt_params -> 'a1 + +val stmt_params_rect_Type0 : + (uns_params -> __ -> (__ -> Graphs.label Types.option) -> Bool.bool -> 'a1) + -> stmt_params -> 'a1 + +val uns_pars : stmt_params -> uns_params + +type succ + +val succ_label : stmt_params -> __ -> Graphs.label Types.option + +val has_fcond : stmt_params -> Bool.bool + +val stmt_params_inv_rect_Type4 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 + +val stmt_params_inv_rect_Type3 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 + +val stmt_params_inv_rect_Type2 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 + +val stmt_params_inv_rect_Type1 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 + +val stmt_params_inv_rect_Type0 : + stmt_params -> (uns_params -> __ -> (__ -> Graphs.label Types.option) -> + Bool.bool -> __ -> 'a1) -> 'a1 + +val stmt_params_jmdiscr : stmt_params -> stmt_params -> __ + +val uns_pars__o__u_pars : stmt_params -> unserialized_params + +type joint_fin_step = +| GOTO of Graphs.label +| RETURN +| TAILCALL of (AST.ident, (__, __) Types.prod) Types.sum * __ + +val joint_fin_step_rect_Type4 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 + +val joint_fin_step_rect_Type5 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 + +val joint_fin_step_rect_Type3 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 + +val joint_fin_step_rect_Type2 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 + +val joint_fin_step_rect_Type1 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 + +val joint_fin_step_rect_Type0 : + unserialized_params -> (Graphs.label -> 'a1) -> 'a1 -> (__ -> (AST.ident, + (__, __) Types.prod) Types.sum -> __ -> 'a1) -> joint_fin_step -> 'a1 + +val joint_fin_step_inv_rect_Type4 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> (__ + -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> + 'a1) -> 'a1 + +val joint_fin_step_inv_rect_Type3 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> (__ + -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> + 'a1) -> 'a1 + +val joint_fin_step_inv_rect_Type2 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> (__ + -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> + 'a1) -> 'a1 + +val joint_fin_step_inv_rect_Type1 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> (__ + -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> + 'a1) -> 'a1 + +val joint_fin_step_inv_rect_Type0 : + unserialized_params -> joint_fin_step -> (Graphs.label -> __ -> 'a1) -> (__ + -> 'a1) -> (__ -> (AST.ident, (__, __) Types.prod) Types.sum -> __ -> __ -> + 'a1) -> 'a1 + +val joint_fin_step_discr : + unserialized_params -> joint_fin_step -> joint_fin_step -> __ + +val joint_fin_step_jmdiscr : + unserialized_params -> joint_fin_step -> joint_fin_step -> __ + +val fin_step_labels : + unserialized_params -> joint_fin_step -> Graphs.label List.list + +type joint_statement = +| Sequential of joint_step * __ +| Final of joint_fin_step +| FCOND of __ * Graphs.label * Graphs.label + +val joint_statement_rect_Type4 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 + +val joint_statement_rect_Type5 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 + +val joint_statement_rect_Type3 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 + +val joint_statement_rect_Type2 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 + +val joint_statement_rect_Type1 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 + +val joint_statement_rect_Type0 : + stmt_params -> AST.ident List.list -> (joint_step -> __ -> 'a1) -> + (joint_fin_step -> 'a1) -> (__ -> __ -> Graphs.label -> Graphs.label -> + 'a1) -> joint_statement -> 'a1 + +val joint_statement_inv_rect_Type4 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> __ + -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> Graphs.label + -> Graphs.label -> __ -> 'a1) -> 'a1 + +val joint_statement_inv_rect_Type3 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> __ + -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> Graphs.label + -> Graphs.label -> __ -> 'a1) -> 'a1 + +val joint_statement_inv_rect_Type2 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> __ + -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> Graphs.label + -> Graphs.label -> __ -> 'a1) -> 'a1 + +val joint_statement_inv_rect_Type1 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> __ + -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> Graphs.label + -> Graphs.label -> __ -> 'a1) -> 'a1 + +val joint_statement_inv_rect_Type0 : + stmt_params -> AST.ident List.list -> joint_statement -> (joint_step -> __ + -> __ -> 'a1) -> (joint_fin_step -> __ -> 'a1) -> (__ -> __ -> Graphs.label + -> Graphs.label -> __ -> 'a1) -> 'a1 + +val joint_statement_discr : + stmt_params -> AST.ident List.list -> joint_statement -> joint_statement -> + __ + +val joint_statement_jmdiscr : + stmt_params -> AST.ident List.list -> joint_statement -> joint_statement -> + __ + +val dpi1__o__fin_step_to_stmt__o__inject : + stmt_params -> AST.ident List.list -> (joint_fin_step, 'a1) Types.dPair -> + joint_statement Types.sig0 + +val eject__o__fin_step_to_stmt__o__inject : + stmt_params -> AST.ident List.list -> joint_fin_step Types.sig0 -> + joint_statement Types.sig0 + +val fin_step_to_stmt__o__inject : + stmt_params -> AST.ident List.list -> joint_fin_step -> joint_statement + Types.sig0 + +val dpi1__o__fin_step_to_stmt : + stmt_params -> AST.ident List.list -> (joint_fin_step, 'a1) Types.dPair -> + joint_statement + +val eject__o__fin_step_to_stmt : + stmt_params -> AST.ident List.list -> joint_fin_step Types.sig0 -> + joint_statement + +type params = { stmt_pars : stmt_params; + stmt_at : (AST.ident List.list -> __ -> __ -> joint_statement + Types.option); + point_of_label : (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option); + point_of_succ : (__ -> __ -> __) } + +val params_rect_Type4 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> 'a1 + +val params_rect_Type5 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> 'a1 + +val params_rect_Type3 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> 'a1 + +val params_rect_Type2 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> 'a1 + +val params_rect_Type1 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> 'a1 + +val params_rect_Type0 : + (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> 'a1) -> params -> 'a1 + +val stmt_pars : params -> stmt_params + +type codeT + +type code_point + +val stmt_at : + params -> AST.ident List.list -> __ -> __ -> joint_statement Types.option + +val point_of_label : + params -> AST.ident List.list -> __ -> Graphs.label -> __ Types.option + +val point_of_succ : params -> __ -> __ -> __ + +val params_inv_rect_Type4 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 + +val params_inv_rect_Type3 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 + +val params_inv_rect_Type2 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 + +val params_inv_rect_Type1 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 + +val params_inv_rect_Type0 : + params -> (stmt_params -> __ -> __ -> (AST.ident List.list -> __ -> __ -> + joint_statement Types.option) -> (AST.ident List.list -> __ -> Graphs.label + -> __ Types.option) -> (__ -> __ -> __) -> __ -> 'a1) -> 'a1 + +val params_jmdiscr : params -> params -> __ + +val stmt_pars__o__uns_pars : params -> uns_params + +val stmt_pars__o__uns_pars__o__u_pars : params -> unserialized_params + +val code_has_point : params -> AST.ident List.list -> __ -> __ -> Bool.bool + +val code_has_label : + params -> AST.ident List.list -> __ -> Graphs.label -> Bool.bool + +val stmt_explicit_labels : + stmt_params -> AST.ident List.list -> joint_statement -> Graphs.label + List.list + +val stmt_implicit_label : + stmt_params -> AST.ident List.list -> joint_statement -> Graphs.label + Types.option + +val stmt_labels : + stmt_params -> AST.ident List.list -> joint_statement -> Graphs.label + List.list + +val stmt_registers : + stmt_params -> AST.ident List.list -> joint_statement -> Registers.register + List.list + +type lin_params = + uns_params + (* singleton inductive, whose constructor was mk_lin_params *) + +val lin_params_rect_Type4 : (uns_params -> 'a1) -> lin_params -> 'a1 + +val lin_params_rect_Type5 : (uns_params -> 'a1) -> lin_params -> 'a1 + +val lin_params_rect_Type3 : (uns_params -> 'a1) -> lin_params -> 'a1 + +val lin_params_rect_Type2 : (uns_params -> 'a1) -> lin_params -> 'a1 + +val lin_params_rect_Type1 : (uns_params -> 'a1) -> lin_params -> 'a1 + +val lin_params_rect_Type0 : (uns_params -> 'a1) -> lin_params -> 'a1 + +val l_u_pars : lin_params -> uns_params + +val lin_params_inv_rect_Type4 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val lin_params_inv_rect_Type3 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val lin_params_inv_rect_Type2 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val lin_params_inv_rect_Type1 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val lin_params_inv_rect_Type0 : + lin_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val lin_params_jmdiscr : lin_params -> lin_params -> __ + +val lin_params_to_params : lin_params -> params + +val lp_to_p__o__stmt_pars : lin_params -> stmt_params + +val lp_to_p__o__stmt_pars__o__uns_pars : lin_params -> uns_params + +val lp_to_p__o__stmt_pars__o__uns_pars__o__u_pars : + lin_params -> unserialized_params + +type graph_params = + uns_params + (* singleton inductive, whose constructor was mk_graph_params *) + +val graph_params_rect_Type4 : (uns_params -> 'a1) -> graph_params -> 'a1 + +val graph_params_rect_Type5 : (uns_params -> 'a1) -> graph_params -> 'a1 + +val graph_params_rect_Type3 : (uns_params -> 'a1) -> graph_params -> 'a1 + +val graph_params_rect_Type2 : (uns_params -> 'a1) -> graph_params -> 'a1 + +val graph_params_rect_Type1 : (uns_params -> 'a1) -> graph_params -> 'a1 + +val graph_params_rect_Type0 : (uns_params -> 'a1) -> graph_params -> 'a1 + +val g_u_pars : graph_params -> uns_params + +val graph_params_inv_rect_Type4 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val graph_params_inv_rect_Type3 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val graph_params_inv_rect_Type2 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val graph_params_inv_rect_Type1 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val graph_params_inv_rect_Type0 : + graph_params -> (uns_params -> __ -> 'a1) -> 'a1 + +val graph_params_jmdiscr : graph_params -> graph_params -> __ + +val graph_params_to_params : graph_params -> params + +val gp_to_p__o__stmt_pars : graph_params -> stmt_params + +val gp_to_p__o__stmt_pars__o__uns_pars : graph_params -> uns_params + +val gp_to_p__o__stmt_pars__o__uns_pars__o__u_pars : + graph_params -> unserialized_params + +type joint_internal_function = { joint_if_luniverse : Identifiers.universe; + joint_if_runiverse : Identifiers.universe; + joint_if_result : __; joint_if_params : + __; joint_if_stacksize : Nat.nat; + joint_if_local_stacksize : Nat.nat; + joint_if_code : __; joint_if_entry : + __ } + +val joint_internal_function_rect_Type4 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> 'a1) + -> joint_internal_function -> 'a1 + +val joint_internal_function_rect_Type5 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> 'a1) + -> joint_internal_function -> 'a1 + +val joint_internal_function_rect_Type3 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> 'a1) + -> joint_internal_function -> 'a1 + +val joint_internal_function_rect_Type2 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> 'a1) + -> joint_internal_function -> 'a1 + +val joint_internal_function_rect_Type1 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> 'a1) + -> joint_internal_function -> 'a1 + +val joint_internal_function_rect_Type0 : + params -> AST.ident List.list -> (Identifiers.universe -> + Identifiers.universe -> __ -> __ -> Nat.nat -> Nat.nat -> __ -> __ -> 'a1) + -> joint_internal_function -> 'a1 + +val joint_if_luniverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe + +val joint_if_runiverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe + +val joint_if_result : + params -> AST.ident List.list -> joint_internal_function -> __ + +val joint_if_params : + params -> AST.ident List.list -> joint_internal_function -> __ + +val joint_if_stacksize : + params -> AST.ident List.list -> joint_internal_function -> Nat.nat + +val joint_if_local_stacksize : + params -> AST.ident List.list -> joint_internal_function -> Nat.nat + +val joint_if_code : + params -> AST.ident List.list -> joint_internal_function -> __ + +val joint_if_entry : + params -> AST.ident List.list -> joint_internal_function -> __ + +val joint_internal_function_inv_rect_Type4 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val joint_internal_function_inv_rect_Type3 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val joint_internal_function_inv_rect_Type2 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val joint_internal_function_inv_rect_Type1 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val joint_internal_function_inv_rect_Type0 : + params -> AST.ident List.list -> joint_internal_function -> + (Identifiers.universe -> Identifiers.universe -> __ -> __ -> Nat.nat -> + Nat.nat -> __ -> __ -> __ -> 'a1) -> 'a1 + +val joint_internal_function_jmdiscr : + params -> AST.ident List.list -> joint_internal_function -> + joint_internal_function -> __ + +val good_if_rect_Type4 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val good_if_rect_Type5 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val good_if_rect_Type3 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val good_if_rect_Type2 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val good_if_rect_Type1 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val good_if_rect_Type0 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val good_if_inv_rect_Type4 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val good_if_inv_rect_Type3 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val good_if_inv_rect_Type2 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val good_if_inv_rect_Type1 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val good_if_inv_rect_Type0 : + params -> AST.ident List.list -> joint_internal_function -> (__ -> __ -> __ + -> __ -> __ -> __ -> 'a1) -> 'a1 + +val good_if_discr : + params -> AST.ident List.list -> joint_internal_function -> __ + +val good_if_jmdiscr : + params -> AST.ident List.list -> joint_internal_function -> __ + +type joint_closed_internal_function = joint_internal_function Types.sig0 + +val set_joint_code : + AST.ident List.list -> params -> joint_internal_function -> __ -> __ -> + joint_internal_function + +val set_luniverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe -> joint_internal_function + +val set_runiverse : + params -> AST.ident List.list -> joint_internal_function -> + Identifiers.universe -> joint_internal_function + +val add_graph : + graph_params -> AST.ident List.list -> Graphs.label -> joint_statement -> + joint_internal_function -> joint_internal_function + +type joint_function = joint_closed_internal_function AST.fundef + +type joint_program = { jp_functions : AST.ident List.list; + joint_prog : (joint_function, AST.init_data List.list) + AST.program; + init_cost_label : CostLabel.costlabel } + +val joint_program_rect_Type4 : + params -> (AST.ident List.list -> (joint_function, AST.init_data List.list) + AST.program -> CostLabel.costlabel -> __ -> 'a1) -> joint_program -> 'a1 + +val joint_program_rect_Type5 : + params -> (AST.ident List.list -> (joint_function, AST.init_data List.list) + AST.program -> CostLabel.costlabel -> __ -> 'a1) -> joint_program -> 'a1 + +val joint_program_rect_Type3 : + params -> (AST.ident List.list -> (joint_function, AST.init_data List.list) + AST.program -> CostLabel.costlabel -> __ -> 'a1) -> joint_program -> 'a1 + +val joint_program_rect_Type2 : + params -> (AST.ident List.list -> (joint_function, AST.init_data List.list) + AST.program -> CostLabel.costlabel -> __ -> 'a1) -> joint_program -> 'a1 + +val joint_program_rect_Type1 : + params -> (AST.ident List.list -> (joint_function, AST.init_data List.list) + AST.program -> CostLabel.costlabel -> __ -> 'a1) -> joint_program -> 'a1 + +val joint_program_rect_Type0 : + params -> (AST.ident List.list -> (joint_function, AST.init_data List.list) + AST.program -> CostLabel.costlabel -> __ -> 'a1) -> joint_program -> 'a1 + +val jp_functions : params -> joint_program -> AST.ident List.list + +val joint_prog : + params -> joint_program -> (joint_function, AST.init_data List.list) + AST.program + +val init_cost_label : params -> joint_program -> CostLabel.costlabel + +val joint_program_inv_rect_Type4 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ -> + 'a1) -> 'a1 + +val joint_program_inv_rect_Type3 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ -> + 'a1) -> 'a1 + +val joint_program_inv_rect_Type2 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ -> + 'a1) -> 'a1 + +val joint_program_inv_rect_Type1 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ -> + 'a1) -> 'a1 + +val joint_program_inv_rect_Type0 : + params -> joint_program -> (AST.ident List.list -> (joint_function, + AST.init_data List.list) AST.program -> CostLabel.costlabel -> __ -> __ -> + 'a1) -> 'a1 + +val joint_program_discr : params -> joint_program -> joint_program -> __ + +val joint_program_jmdiscr : params -> joint_program -> joint_program -> __ + +val dpi1__o__joint_prog__o__inject : + params -> (joint_program, 'a1) Types.dPair -> (joint_function, + AST.init_data List.list) AST.program Types.sig0 + +val eject__o__joint_prog__o__inject : + params -> joint_program Types.sig0 -> (joint_function, AST.init_data + List.list) AST.program Types.sig0 + +val joint_prog__o__inject : + params -> joint_program -> (joint_function, AST.init_data List.list) + AST.program Types.sig0 + +val dpi1__o__joint_prog : + params -> (joint_program, 'a1) Types.dPair -> (joint_function, + AST.init_data List.list) AST.program + +val eject__o__joint_prog : + params -> joint_program Types.sig0 -> (joint_function, AST.init_data + List.list) AST.program + +val prog_names : params -> joint_program -> AST.ident List.list + +val transform_joint_program : + params -> params -> (AST.ident List.list -> joint_closed_internal_function + -> joint_closed_internal_function) -> joint_program -> joint_program + +type stack_cost_model = (AST.ident, Nat.nat) Types.prod List.list + +val stack_cost : params -> joint_program -> stack_cost_model + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +val globals_stacksize : params -> joint_program -> Nat.nat + diff --git a/extracted/joint_LTL_LIN.ml b/extracted/joint_LTL_LIN.ml new file mode 100644 index 0000000..2ad15ef --- /dev/null +++ b/extracted/joint_LTL_LIN.ml @@ -0,0 +1,380 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type registers_move = +| From_acc of I8051.register * Types.unit0 +| To_acc of Types.unit0 * I8051.register +| Int_to_reg of I8051.register * BitVector.byte +| Int_to_acc of Types.unit0 * BitVector.byte + +(** val registers_move_rect_Type4 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register + -> 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 **) +let rec registers_move_rect_Type4 h_from_acc h_to_acc h_int_to_reg h_int_to_acc = function +| From_acc (x_18638, x_18637) -> h_from_acc x_18638 x_18637 +| To_acc (x_18640, x_18639) -> h_to_acc x_18640 x_18639 +| Int_to_reg (x_18642, x_18641) -> h_int_to_reg x_18642 x_18641 +| Int_to_acc (x_18644, x_18643) -> h_int_to_acc x_18644 x_18643 + +(** val registers_move_rect_Type5 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register + -> 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 **) +let rec registers_move_rect_Type5 h_from_acc h_to_acc h_int_to_reg h_int_to_acc = function +| From_acc (x_18651, x_18650) -> h_from_acc x_18651 x_18650 +| To_acc (x_18653, x_18652) -> h_to_acc x_18653 x_18652 +| Int_to_reg (x_18655, x_18654) -> h_int_to_reg x_18655 x_18654 +| Int_to_acc (x_18657, x_18656) -> h_int_to_acc x_18657 x_18656 + +(** val registers_move_rect_Type3 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register + -> 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 **) +let rec registers_move_rect_Type3 h_from_acc h_to_acc h_int_to_reg h_int_to_acc = function +| From_acc (x_18664, x_18663) -> h_from_acc x_18664 x_18663 +| To_acc (x_18666, x_18665) -> h_to_acc x_18666 x_18665 +| Int_to_reg (x_18668, x_18667) -> h_int_to_reg x_18668 x_18667 +| Int_to_acc (x_18670, x_18669) -> h_int_to_acc x_18670 x_18669 + +(** val registers_move_rect_Type2 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register + -> 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 **) +let rec registers_move_rect_Type2 h_from_acc h_to_acc h_int_to_reg h_int_to_acc = function +| From_acc (x_18677, x_18676) -> h_from_acc x_18677 x_18676 +| To_acc (x_18679, x_18678) -> h_to_acc x_18679 x_18678 +| Int_to_reg (x_18681, x_18680) -> h_int_to_reg x_18681 x_18680 +| Int_to_acc (x_18683, x_18682) -> h_int_to_acc x_18683 x_18682 + +(** val registers_move_rect_Type1 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register + -> 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 **) +let rec registers_move_rect_Type1 h_from_acc h_to_acc h_int_to_reg h_int_to_acc = function +| From_acc (x_18690, x_18689) -> h_from_acc x_18690 x_18689 +| To_acc (x_18692, x_18691) -> h_to_acc x_18692 x_18691 +| Int_to_reg (x_18694, x_18693) -> h_int_to_reg x_18694 x_18693 +| Int_to_acc (x_18696, x_18695) -> h_int_to_acc x_18696 x_18695 + +(** val registers_move_rect_Type0 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register + -> 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 **) +let rec registers_move_rect_Type0 h_from_acc h_to_acc h_int_to_reg h_int_to_acc = function +| From_acc (x_18703, x_18702) -> h_from_acc x_18703 x_18702 +| To_acc (x_18705, x_18704) -> h_to_acc x_18705 x_18704 +| Int_to_reg (x_18707, x_18706) -> h_int_to_reg x_18707 x_18706 +| Int_to_acc (x_18709, x_18708) -> h_int_to_acc x_18709 x_18708 + +(** val registers_move_inv_rect_Type4 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 **) +let registers_move_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = registers_move_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val registers_move_inv_rect_Type3 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 **) +let registers_move_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = registers_move_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val registers_move_inv_rect_Type2 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 **) +let registers_move_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = registers_move_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val registers_move_inv_rect_Type1 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 **) +let registers_move_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = registers_move_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val registers_move_inv_rect_Type0 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 **) +let registers_move_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = registers_move_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val registers_move_discr : registers_move -> registers_move -> __ **) +let registers_move_discr x y = + Logic.eq_rect_Type2 x + (match x with + | From_acc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | To_acc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Int_to_reg (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Int_to_acc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val registers_move_jmdiscr : registers_move -> registers_move -> __ **) +let registers_move_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | From_acc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | To_acc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Int_to_reg (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Int_to_acc (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +type ltl_lin_seq = +| SAVE_CARRY +| RESTORE_CARRY +| LOW_ADDRESS of Graphs.label +| HIGH_ADDRESS of Graphs.label + +(** val ltl_lin_seq_rect_Type4 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> + ltl_lin_seq -> 'a1 **) +let rec ltl_lin_seq_rect_Type4 h_SAVE_CARRY h_RESTORE_CARRY h_LOW_ADDRESS h_HIGH_ADDRESS = function +| SAVE_CARRY -> h_SAVE_CARRY +| RESTORE_CARRY -> h_RESTORE_CARRY +| LOW_ADDRESS x_18800 -> h_LOW_ADDRESS x_18800 +| HIGH_ADDRESS x_18801 -> h_HIGH_ADDRESS x_18801 + +(** val ltl_lin_seq_rect_Type5 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> + ltl_lin_seq -> 'a1 **) +let rec ltl_lin_seq_rect_Type5 h_SAVE_CARRY h_RESTORE_CARRY h_LOW_ADDRESS h_HIGH_ADDRESS = function +| SAVE_CARRY -> h_SAVE_CARRY +| RESTORE_CARRY -> h_RESTORE_CARRY +| LOW_ADDRESS x_18807 -> h_LOW_ADDRESS x_18807 +| HIGH_ADDRESS x_18808 -> h_HIGH_ADDRESS x_18808 + +(** val ltl_lin_seq_rect_Type3 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> + ltl_lin_seq -> 'a1 **) +let rec ltl_lin_seq_rect_Type3 h_SAVE_CARRY h_RESTORE_CARRY h_LOW_ADDRESS h_HIGH_ADDRESS = function +| SAVE_CARRY -> h_SAVE_CARRY +| RESTORE_CARRY -> h_RESTORE_CARRY +| LOW_ADDRESS x_18814 -> h_LOW_ADDRESS x_18814 +| HIGH_ADDRESS x_18815 -> h_HIGH_ADDRESS x_18815 + +(** val ltl_lin_seq_rect_Type2 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> + ltl_lin_seq -> 'a1 **) +let rec ltl_lin_seq_rect_Type2 h_SAVE_CARRY h_RESTORE_CARRY h_LOW_ADDRESS h_HIGH_ADDRESS = function +| SAVE_CARRY -> h_SAVE_CARRY +| RESTORE_CARRY -> h_RESTORE_CARRY +| LOW_ADDRESS x_18821 -> h_LOW_ADDRESS x_18821 +| HIGH_ADDRESS x_18822 -> h_HIGH_ADDRESS x_18822 + +(** val ltl_lin_seq_rect_Type1 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> + ltl_lin_seq -> 'a1 **) +let rec ltl_lin_seq_rect_Type1 h_SAVE_CARRY h_RESTORE_CARRY h_LOW_ADDRESS h_HIGH_ADDRESS = function +| SAVE_CARRY -> h_SAVE_CARRY +| RESTORE_CARRY -> h_RESTORE_CARRY +| LOW_ADDRESS x_18828 -> h_LOW_ADDRESS x_18828 +| HIGH_ADDRESS x_18829 -> h_HIGH_ADDRESS x_18829 + +(** val ltl_lin_seq_rect_Type0 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> + ltl_lin_seq -> 'a1 **) +let rec ltl_lin_seq_rect_Type0 h_SAVE_CARRY h_RESTORE_CARRY h_LOW_ADDRESS h_HIGH_ADDRESS = function +| SAVE_CARRY -> h_SAVE_CARRY +| RESTORE_CARRY -> h_RESTORE_CARRY +| LOW_ADDRESS x_18835 -> h_LOW_ADDRESS x_18835 +| HIGH_ADDRESS x_18836 -> h_HIGH_ADDRESS x_18836 + +(** val ltl_lin_seq_inv_rect_Type4 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) + -> (Graphs.label -> __ -> 'a1) -> 'a1 **) +let ltl_lin_seq_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = ltl_lin_seq_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val ltl_lin_seq_inv_rect_Type3 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) + -> (Graphs.label -> __ -> 'a1) -> 'a1 **) +let ltl_lin_seq_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = ltl_lin_seq_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val ltl_lin_seq_inv_rect_Type2 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) + -> (Graphs.label -> __ -> 'a1) -> 'a1 **) +let ltl_lin_seq_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = ltl_lin_seq_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val ltl_lin_seq_inv_rect_Type1 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) + -> (Graphs.label -> __ -> 'a1) -> 'a1 **) +let ltl_lin_seq_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = ltl_lin_seq_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val ltl_lin_seq_inv_rect_Type0 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) + -> (Graphs.label -> __ -> 'a1) -> 'a1 **) +let ltl_lin_seq_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = ltl_lin_seq_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val ltl_lin_seq_discr : ltl_lin_seq -> ltl_lin_seq -> __ **) +let ltl_lin_seq_discr x y = + Logic.eq_rect_Type2 x + (match x with + | SAVE_CARRY -> Obj.magic (fun _ dH -> dH) + | RESTORE_CARRY -> Obj.magic (fun _ dH -> dH) + | LOW_ADDRESS a0 -> Obj.magic (fun _ dH -> dH __) + | HIGH_ADDRESS a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val ltl_lin_seq_jmdiscr : ltl_lin_seq -> ltl_lin_seq -> __ **) +let ltl_lin_seq_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | SAVE_CARRY -> Obj.magic (fun _ dH -> dH) + | RESTORE_CARRY -> Obj.magic (fun _ dH -> dH) + | LOW_ADDRESS a0 -> Obj.magic (fun _ dH -> dH __) + | HIGH_ADDRESS a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val ltl_lin_seq_labels : ltl_lin_seq -> Graphs.label List.list **) +let ltl_lin_seq_labels = function +| SAVE_CARRY -> List.Nil +| RESTORE_CARRY -> List.Nil +| LOW_ADDRESS lbl -> List.Cons (lbl, List.Nil) +| HIGH_ADDRESS lbl -> List.Cons (lbl, List.Nil) + +(** val lTL_LIN_uns : Joint.unserialized_params **) +let lTL_LIN_uns = + { Joint.ext_seq_labels = (Obj.magic ltl_lin_seq_labels); + Joint.has_tailcalls = Bool.False } + +(** val lTL_LIN_functs : Joint.get_pseudo_reg_functs **) +let lTL_LIN_functs = + { Joint.acc_a_regs = (fun x -> List.Nil); Joint.acc_b_regs = (fun x -> + List.Nil); Joint.acc_a_args = (fun x -> List.Nil); Joint.acc_b_args = + (fun x -> List.Nil); Joint.dpl_regs = (fun x -> List.Nil); + Joint.dph_regs = (fun x -> List.Nil); Joint.dpl_args = (fun x -> + List.Nil); Joint.dph_args = (fun x -> List.Nil); Joint.snd_args = + (fun x -> List.Nil); Joint.pair_move_regs = (fun x -> List.Nil); + Joint.f_call_args = (fun x -> List.Nil); Joint.f_call_dest = (fun x -> + List.Nil); Joint.ext_seq_regs = (fun x -> List.Nil); Joint.params_regs = + (fun x -> List.Nil) } + +(** val lTL_LIN : Joint.uns_params **) +let lTL_LIN = + { Joint.u_pars = lTL_LIN_uns; Joint.functs = lTL_LIN_functs } + diff --git a/extracted/joint_LTL_LIN.mli b/extracted/joint_LTL_LIN.mli new file mode 100644 index 0000000..a4aac88 --- /dev/null +++ b/extracted/joint_LTL_LIN.mli @@ -0,0 +1,252 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type registers_move = +| From_acc of I8051.register * Types.unit0 +| To_acc of Types.unit0 * I8051.register +| Int_to_reg of I8051.register * BitVector.byte +| Int_to_acc of Types.unit0 * BitVector.byte + +val registers_move_rect_Type4 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register -> + 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 + +val registers_move_rect_Type5 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register -> + 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 + +val registers_move_rect_Type3 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register -> + 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 + +val registers_move_rect_Type2 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register -> + 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 + +val registers_move_rect_Type1 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register -> + 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 + +val registers_move_rect_Type0 : + (I8051.register -> Types.unit0 -> 'a1) -> (Types.unit0 -> I8051.register -> + 'a1) -> (I8051.register -> BitVector.byte -> 'a1) -> (Types.unit0 -> + BitVector.byte -> 'a1) -> registers_move -> 'a1 + +val registers_move_inv_rect_Type4 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 + +val registers_move_inv_rect_Type3 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 + +val registers_move_inv_rect_Type2 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 + +val registers_move_inv_rect_Type1 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 + +val registers_move_inv_rect_Type0 : + registers_move -> (I8051.register -> Types.unit0 -> __ -> 'a1) -> + (Types.unit0 -> I8051.register -> __ -> 'a1) -> (I8051.register -> + BitVector.byte -> __ -> 'a1) -> (Types.unit0 -> BitVector.byte -> __ -> + 'a1) -> 'a1 + +val registers_move_discr : registers_move -> registers_move -> __ + +val registers_move_jmdiscr : registers_move -> registers_move -> __ + +type ltl_lin_seq = +| SAVE_CARRY +| RESTORE_CARRY +| LOW_ADDRESS of Graphs.label +| HIGH_ADDRESS of Graphs.label + +val ltl_lin_seq_rect_Type4 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> ltl_lin_seq + -> 'a1 + +val ltl_lin_seq_rect_Type5 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> ltl_lin_seq + -> 'a1 + +val ltl_lin_seq_rect_Type3 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> ltl_lin_seq + -> 'a1 + +val ltl_lin_seq_rect_Type2 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> ltl_lin_seq + -> 'a1 + +val ltl_lin_seq_rect_Type1 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> ltl_lin_seq + -> 'a1 + +val ltl_lin_seq_rect_Type0 : + 'a1 -> 'a1 -> (Graphs.label -> 'a1) -> (Graphs.label -> 'a1) -> ltl_lin_seq + -> 'a1 + +val ltl_lin_seq_inv_rect_Type4 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) -> + (Graphs.label -> __ -> 'a1) -> 'a1 + +val ltl_lin_seq_inv_rect_Type3 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) -> + (Graphs.label -> __ -> 'a1) -> 'a1 + +val ltl_lin_seq_inv_rect_Type2 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) -> + (Graphs.label -> __ -> 'a1) -> 'a1 + +val ltl_lin_seq_inv_rect_Type1 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) -> + (Graphs.label -> __ -> 'a1) -> 'a1 + +val ltl_lin_seq_inv_rect_Type0 : + ltl_lin_seq -> (__ -> 'a1) -> (__ -> 'a1) -> (Graphs.label -> __ -> 'a1) -> + (Graphs.label -> __ -> 'a1) -> 'a1 + +val ltl_lin_seq_discr : ltl_lin_seq -> ltl_lin_seq -> __ + +val ltl_lin_seq_jmdiscr : ltl_lin_seq -> ltl_lin_seq -> __ + +val ltl_lin_seq_labels : ltl_lin_seq -> Graphs.label List.list + +val lTL_LIN_uns : Joint.unserialized_params + +val lTL_LIN_functs : Joint.get_pseudo_reg_functs + +val lTL_LIN : Joint.uns_params + diff --git a/extracted/joint_LTL_LIN_semantics.ml b/extracted/joint_LTL_LIN_semantics.ml new file mode 100644 index 0000000..602adf5 --- /dev/null +++ b/extracted/joint_LTL_LIN_semantics.ml @@ -0,0 +1,324 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Events + +open IOMonad + +open IO + +open Joint_semantics + +open SemanticsUtils + +(** val hw_reg_store : + I8051.register -> ByteValues.beval -> SemanticsUtils.hw_register_env -> + SemanticsUtils.hw_register_env Errors.res **) +let hw_reg_store r v e = + Errors.OK (SemanticsUtils.hwreg_store r v e) + +(** val hw_reg_retrieve : + SemanticsUtils.hw_register_env -> I8051.register -> ByteValues.beval + Errors.res **) +let hw_reg_retrieve l r = + Errors.OK (SemanticsUtils.hwreg_retrieve l r) + +(** val hw_arg_retrieve : + SemanticsUtils.hw_register_env -> I8051.register Joint.argument -> + ByteValues.beval Errors.res **) +let hw_arg_retrieve l = function +| Joint.Reg r -> hw_reg_retrieve l r +| Joint.Imm b -> Errors.OK (ByteValues.BVByte b) + +(** val eval_registers_move : + SemanticsUtils.hw_register_env -> Joint_LTL_LIN.registers_move -> + SemanticsUtils.hw_register_env Errors.res **) +let eval_registers_move e = function +| Joint_LTL_LIN.From_acc (r, x) -> + hw_reg_store r (SemanticsUtils.hwreg_retrieve e I8051.RegisterA) e +| Joint_LTL_LIN.To_acc (x, r) -> + hw_reg_store I8051.RegisterA (SemanticsUtils.hwreg_retrieve e r) e +| Joint_LTL_LIN.Int_to_reg (r, v) -> hw_reg_store r (ByteValues.BVByte v) e +| Joint_LTL_LIN.Int_to_acc (x, v) -> + hw_reg_store I8051.RegisterA (ByteValues.BVByte v) e + +(** val lTL_LIN_state : Joint_semantics.sem_state_params **) +let lTL_LIN_state = + { Joint_semantics.empty_framesT = (Obj.magic Types.It); + Joint_semantics.empty_regsT = + (Obj.magic SemanticsUtils.init_hw_register_env); + Joint_semantics.load_sp = (Obj.magic SemanticsUtils.hwreg_retrieve_sp); + Joint_semantics.save_sp = (Obj.magic SemanticsUtils.hwreg_store_sp) } + +(** val ltl_lin_fetch_external_args : + AST.external_function -> Joint_semantics.state -> Nat.nat -> Values.val0 + List.list Errors.res **) +let ltl_lin_fetch_external_args _ = + failwith "AXIOM TO BE REALIZED" + +(** val ltl_lin_set_result : + Values.val0 List.list -> Types.unit0 -> Joint_semantics.state -> + Joint_semantics.state Errors.res **) +let ltl_lin_set_result _ = + failwith "AXIOM TO BE REALIZED" + +(** val lTL_LIN_save_frame : + Joint_semantics.call_kind -> Types.unit0 -> Joint_semantics.state_pc -> + Joint_semantics.state Errors.res **) +let lTL_LIN_save_frame k x st = + match k with + | Joint_semantics.PTR -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (ByteValues.byte_of_val ErrorMessages.BadFunction + (SemanticsUtils.hwreg_retrieve + (Obj.magic st.Joint_semantics.st_no_pc.Joint_semantics.regs) + I8051.RegisterA))) (fun v -> + match BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) v + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) with + | Bool.True -> + Monad.m_return0 (Monad.max_def Errors.res0) + st.Joint_semantics.st_no_pc + | Bool.False -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.MSG + ErrorMessages.BadPointer), List.Nil))))))) + | Joint_semantics.ID -> + Joint_semantics.push_ra lTL_LIN_state st.Joint_semantics.st_no_pc + st.Joint_semantics.pc + +(** val eval_LTL_LIN_ext_seq : + AST.ident List.list -> 'a1 Joint_semantics.genv_gen -> + Joint_LTL_LIN.ltl_lin_seq -> AST.ident -> Joint_semantics.state -> + Joint_semantics.state Errors.res **) +let eval_LTL_LIN_ext_seq globals ge s curr_id st = + match s with + | Joint_LTL_LIN.SAVE_CARRY -> + let regs = + SemanticsUtils.hwreg_set_other st.Joint_semantics.carry + (Obj.magic st.Joint_semantics.regs) + in + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_regs lTL_LIN_state (Obj.magic regs) st)) + | Joint_LTL_LIN.RESTORE_CARRY -> + let carry = (Obj.magic st.Joint_semantics.regs).SemanticsUtils.other_bit + in + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_carry lTL_LIN_state carry st)) + | Joint_LTL_LIN.LOW_ADDRESS l -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.gen_pc_from_label globals ge curr_id l)) + (fun pc_lab -> + let { Types.fst = addrl; Types.snd = addrh } = + ByteValues.beval_pair_of_pc pc_lab + in + let regs = + SemanticsUtils.hwreg_store I8051.RegisterA addrl + (Obj.magic st.Joint_semantics.regs) + in + Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_regs lTL_LIN_state (Obj.magic regs) st))) + | Joint_LTL_LIN.HIGH_ADDRESS l -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.gen_pc_from_label globals ge curr_id l)) + (fun pc_lab -> + let { Types.fst = addrl; Types.snd = addrh } = + ByteValues.beval_pair_of_pc pc_lab + in + let regs = + SemanticsUtils.hwreg_store I8051.RegisterA addrh + (Obj.magic st.Joint_semantics.regs) + in + Monad.m_return0 (Monad.max_def Errors.res0) + (Joint_semantics.set_regs lTL_LIN_state (Obj.magic regs) st))) + +(** val lTL_LIN_semantics : 'a1 Joint_semantics.sem_unserialized_params **) +let lTL_LIN_semantics = + { Joint_semantics.st_pars = lTL_LIN_state; Joint_semantics.acca_store_ = + (fun x -> Obj.magic (hw_reg_store I8051.RegisterA)); + Joint_semantics.acca_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterA); + Joint_semantics.acca_arg_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterA); + Joint_semantics.accb_store_ = (fun x -> + Obj.magic (hw_reg_store I8051.RegisterB)); + Joint_semantics.accb_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterB); + Joint_semantics.accb_arg_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterB); + Joint_semantics.dpl_store_ = (fun x -> + Obj.magic (hw_reg_store I8051.RegisterDPL)); + Joint_semantics.dpl_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterDPL); + Joint_semantics.dpl_arg_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterDPL); + Joint_semantics.dph_store_ = (fun x -> + Obj.magic (hw_reg_store I8051.RegisterDPH)); + Joint_semantics.dph_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterDPH); + Joint_semantics.dph_arg_retrieve_ = (fun e x -> + hw_reg_retrieve (Obj.magic e) I8051.RegisterDPH); + Joint_semantics.snd_arg_retrieve_ = (Obj.magic hw_arg_retrieve); + Joint_semantics.pair_reg_move_ = (Obj.magic eval_registers_move); + Joint_semantics.save_frame = (Obj.magic lTL_LIN_save_frame); + Joint_semantics.setup_call = (fun x x0 x1 st -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st)); + Joint_semantics.fetch_external_args = + (Obj.magic ltl_lin_fetch_external_args); Joint_semantics.set_result = + (Obj.magic ltl_lin_set_result); Joint_semantics.call_args_for_main = + (Obj.magic Nat.O); Joint_semantics.call_dest_for_main = + (Obj.magic Types.It); Joint_semantics.read_result = (fun x x0 x1 st -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + (List.map + (SemanticsUtils.hwreg_retrieve (Obj.magic st.Joint_semantics.regs)) + I8051.registerRets))); Joint_semantics.eval_ext_seq = + (Obj.magic eval_LTL_LIN_ext_seq); Joint_semantics.pop_frame = + (fun x x0 x1 x2 st -> Joint_semantics.pop_ra lTL_LIN_state st) } + diff --git a/extracted/joint_LTL_LIN_semantics.mli b/extracted/joint_LTL_LIN_semantics.mli new file mode 100644 index 0000000..5050ac1 --- /dev/null +++ b/extracted/joint_LTL_LIN_semantics.mli @@ -0,0 +1,189 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Events + +open IOMonad + +open IO + +open Joint_semantics + +open SemanticsUtils + +val hw_reg_store : + I8051.register -> ByteValues.beval -> SemanticsUtils.hw_register_env -> + SemanticsUtils.hw_register_env Errors.res + +val hw_reg_retrieve : + SemanticsUtils.hw_register_env -> I8051.register -> ByteValues.beval + Errors.res + +val hw_arg_retrieve : + SemanticsUtils.hw_register_env -> I8051.register Joint.argument -> + ByteValues.beval Errors.res + +val eval_registers_move : + SemanticsUtils.hw_register_env -> Joint_LTL_LIN.registers_move -> + SemanticsUtils.hw_register_env Errors.res + +val lTL_LIN_state : Joint_semantics.sem_state_params + +val ltl_lin_fetch_external_args : + AST.external_function -> Joint_semantics.state -> Nat.nat -> Values.val0 + List.list Errors.res + +val ltl_lin_set_result : + Values.val0 List.list -> Types.unit0 -> Joint_semantics.state -> + Joint_semantics.state Errors.res + +val lTL_LIN_save_frame : + Joint_semantics.call_kind -> Types.unit0 -> Joint_semantics.state_pc -> + Joint_semantics.state Errors.res + +val eval_LTL_LIN_ext_seq : + AST.ident List.list -> 'a1 Joint_semantics.genv_gen -> + Joint_LTL_LIN.ltl_lin_seq -> AST.ident -> Joint_semantics.state -> + Joint_semantics.state Errors.res + +val lTL_LIN_semantics : __ Joint_semantics.sem_unserialized_params + diff --git a/extracted/joint_fullexec.ml b/extracted/joint_fullexec.ml new file mode 100644 index 0000000..287423c --- /dev/null +++ b/extracted/joint_fullexec.ml @@ -0,0 +1,212 @@ +open Preamble + +open StructuredTraces + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open Traces + +open Stacksize + +open SmallstepExec + +open Executions + +open Measurable + +(** val joint_exec : + Joint_semantics.sem_params -> (IO.io_out, IO.io_in) + SmallstepExec.trans_system **) +let joint_exec g = + { SmallstepExec.is_final = (fun env -> + Obj.magic (Traces.joint_final g (Obj.magic env))); SmallstepExec.step = + (fun env st -> + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (Joint_semantics.eval_state g (Obj.magic env).Traces.globals + (Obj.magic env).Traces.ev_genv (Obj.magic st))) (fun st' -> + let charge = + match Traces.joint_label_of_pc g (Obj.magic env) + (Obj.magic st).Joint_semantics.pc with + | Types.None -> Events.e0 + | Types.Some c -> Events.echarge c + in + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { Types.fst = charge; + Types.snd = st' }))) } + +(** val joint_fullexec : + Joint_semantics.sem_params -> (IO.io_out, IO.io_in) + SmallstepExec.fullexec **) +let joint_fullexec g = + { SmallstepExec.es1 = (joint_exec g); SmallstepExec.make_global = + (fun pr -> + Obj.magic + (Traces.joint_make_global { Traces.prog_spars = g; Traces.prog = + (Obj.magic pr).Types.fst; Traces.stack_sizes = + (Obj.magic pr).Types.snd })); SmallstepExec.make_initial_state = + (fun p_stacks -> + Obj.magic + (Traces.make_initial_state { Traces.prog_spars = g; Traces.prog = + (Obj.magic p_stacks).Types.fst; Traces.stack_sizes = + (Obj.magic p_stacks).Types.snd })) } + +(** val joint_preclassified_system : + Joint_semantics.sem_params -> Measurable.preclassified_system **) +let joint_preclassified_system g = + { Measurable.pcs_exec = (joint_fullexec g); Measurable.pcs_labelled = + (fun env st -> + Bool.notb + (PositiveMap.is_none + (Traces.joint_label_of_pc g (Obj.magic env) + (Obj.magic st).Joint_semantics.pc))); Measurable.pcs_classify = + (fun env -> Obj.magic (Traces.joint_classify g (Obj.magic env))); + Measurable.pcs_callee = (fun env s _ -> + Traces.joint_call_ident g (Obj.magic env) (Obj.magic s)) } + diff --git a/extracted/joint_fullexec.mli b/extracted/joint_fullexec.mli new file mode 100644 index 0000000..6563b4b --- /dev/null +++ b/extracted/joint_fullexec.mli @@ -0,0 +1,172 @@ +open Preamble + +open StructuredTraces + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open Traces + +open Stacksize + +open SmallstepExec + +open Executions + +open Measurable + +val joint_exec : + Joint_semantics.sem_params -> (IO.io_out, IO.io_in) + SmallstepExec.trans_system + +val joint_fullexec : + Joint_semantics.sem_params -> (IO.io_out, IO.io_in) SmallstepExec.fullexec + +val joint_preclassified_system : + Joint_semantics.sem_params -> Measurable.preclassified_system + diff --git a/extracted/joint_printer.ml b/extracted/joint_printer.ml new file mode 100644 index 0000000..f463f2c --- /dev/null +++ b/extracted/joint_printer.ml @@ -0,0 +1,1467 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type keyword = +| KwCOMMENT +| KwMOVE +| KwPOP +| KwPUSH +| KwADDRESS +| KwOPACCS +| KwOP1 +| KwOP2 +| KwCLEAR_CARRY +| KwSET_CARRY +| KwLOAD +| KwSTORE +| KwCOST_LABEL +| KwCOND +| KwCALL +| KwGOTO +| KwRETURN +| KwTAILCALL +| KwFCOND + +(** val keyword_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 **) +let rec keyword_rect_Type4 h_kwCOMMENT h_kwMOVE h_kwPOP h_kwPUSH h_kwADDRESS h_kwOPACCS h_kwOP1 h_kwOP2 h_kwCLEAR_CARRY h_kwSET_CARRY h_kwLOAD h_kwSTORE h_kwCOST_LABEL h_kwCOND h_kwCALL h_kwGOTO h_kwRETURN h_kwTAILCALL h_kwFCOND = function +| KwCOMMENT -> h_kwCOMMENT +| KwMOVE -> h_kwMOVE +| KwPOP -> h_kwPOP +| KwPUSH -> h_kwPUSH +| KwADDRESS -> h_kwADDRESS +| KwOPACCS -> h_kwOPACCS +| KwOP1 -> h_kwOP1 +| KwOP2 -> h_kwOP2 +| KwCLEAR_CARRY -> h_kwCLEAR_CARRY +| KwSET_CARRY -> h_kwSET_CARRY +| KwLOAD -> h_kwLOAD +| KwSTORE -> h_kwSTORE +| KwCOST_LABEL -> h_kwCOST_LABEL +| KwCOND -> h_kwCOND +| KwCALL -> h_kwCALL +| KwGOTO -> h_kwGOTO +| KwRETURN -> h_kwRETURN +| KwTAILCALL -> h_kwTAILCALL +| KwFCOND -> h_kwFCOND + +(** val keyword_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 **) +let rec keyword_rect_Type5 h_kwCOMMENT h_kwMOVE h_kwPOP h_kwPUSH h_kwADDRESS h_kwOPACCS h_kwOP1 h_kwOP2 h_kwCLEAR_CARRY h_kwSET_CARRY h_kwLOAD h_kwSTORE h_kwCOST_LABEL h_kwCOND h_kwCALL h_kwGOTO h_kwRETURN h_kwTAILCALL h_kwFCOND = function +| KwCOMMENT -> h_kwCOMMENT +| KwMOVE -> h_kwMOVE +| KwPOP -> h_kwPOP +| KwPUSH -> h_kwPUSH +| KwADDRESS -> h_kwADDRESS +| KwOPACCS -> h_kwOPACCS +| KwOP1 -> h_kwOP1 +| KwOP2 -> h_kwOP2 +| KwCLEAR_CARRY -> h_kwCLEAR_CARRY +| KwSET_CARRY -> h_kwSET_CARRY +| KwLOAD -> h_kwLOAD +| KwSTORE -> h_kwSTORE +| KwCOST_LABEL -> h_kwCOST_LABEL +| KwCOND -> h_kwCOND +| KwCALL -> h_kwCALL +| KwGOTO -> h_kwGOTO +| KwRETURN -> h_kwRETURN +| KwTAILCALL -> h_kwTAILCALL +| KwFCOND -> h_kwFCOND + +(** val keyword_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 **) +let rec keyword_rect_Type3 h_kwCOMMENT h_kwMOVE h_kwPOP h_kwPUSH h_kwADDRESS h_kwOPACCS h_kwOP1 h_kwOP2 h_kwCLEAR_CARRY h_kwSET_CARRY h_kwLOAD h_kwSTORE h_kwCOST_LABEL h_kwCOND h_kwCALL h_kwGOTO h_kwRETURN h_kwTAILCALL h_kwFCOND = function +| KwCOMMENT -> h_kwCOMMENT +| KwMOVE -> h_kwMOVE +| KwPOP -> h_kwPOP +| KwPUSH -> h_kwPUSH +| KwADDRESS -> h_kwADDRESS +| KwOPACCS -> h_kwOPACCS +| KwOP1 -> h_kwOP1 +| KwOP2 -> h_kwOP2 +| KwCLEAR_CARRY -> h_kwCLEAR_CARRY +| KwSET_CARRY -> h_kwSET_CARRY +| KwLOAD -> h_kwLOAD +| KwSTORE -> h_kwSTORE +| KwCOST_LABEL -> h_kwCOST_LABEL +| KwCOND -> h_kwCOND +| KwCALL -> h_kwCALL +| KwGOTO -> h_kwGOTO +| KwRETURN -> h_kwRETURN +| KwTAILCALL -> h_kwTAILCALL +| KwFCOND -> h_kwFCOND + +(** val keyword_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 **) +let rec keyword_rect_Type2 h_kwCOMMENT h_kwMOVE h_kwPOP h_kwPUSH h_kwADDRESS h_kwOPACCS h_kwOP1 h_kwOP2 h_kwCLEAR_CARRY h_kwSET_CARRY h_kwLOAD h_kwSTORE h_kwCOST_LABEL h_kwCOND h_kwCALL h_kwGOTO h_kwRETURN h_kwTAILCALL h_kwFCOND = function +| KwCOMMENT -> h_kwCOMMENT +| KwMOVE -> h_kwMOVE +| KwPOP -> h_kwPOP +| KwPUSH -> h_kwPUSH +| KwADDRESS -> h_kwADDRESS +| KwOPACCS -> h_kwOPACCS +| KwOP1 -> h_kwOP1 +| KwOP2 -> h_kwOP2 +| KwCLEAR_CARRY -> h_kwCLEAR_CARRY +| KwSET_CARRY -> h_kwSET_CARRY +| KwLOAD -> h_kwLOAD +| KwSTORE -> h_kwSTORE +| KwCOST_LABEL -> h_kwCOST_LABEL +| KwCOND -> h_kwCOND +| KwCALL -> h_kwCALL +| KwGOTO -> h_kwGOTO +| KwRETURN -> h_kwRETURN +| KwTAILCALL -> h_kwTAILCALL +| KwFCOND -> h_kwFCOND + +(** val keyword_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 **) +let rec keyword_rect_Type1 h_kwCOMMENT h_kwMOVE h_kwPOP h_kwPUSH h_kwADDRESS h_kwOPACCS h_kwOP1 h_kwOP2 h_kwCLEAR_CARRY h_kwSET_CARRY h_kwLOAD h_kwSTORE h_kwCOST_LABEL h_kwCOND h_kwCALL h_kwGOTO h_kwRETURN h_kwTAILCALL h_kwFCOND = function +| KwCOMMENT -> h_kwCOMMENT +| KwMOVE -> h_kwMOVE +| KwPOP -> h_kwPOP +| KwPUSH -> h_kwPUSH +| KwADDRESS -> h_kwADDRESS +| KwOPACCS -> h_kwOPACCS +| KwOP1 -> h_kwOP1 +| KwOP2 -> h_kwOP2 +| KwCLEAR_CARRY -> h_kwCLEAR_CARRY +| KwSET_CARRY -> h_kwSET_CARRY +| KwLOAD -> h_kwLOAD +| KwSTORE -> h_kwSTORE +| KwCOST_LABEL -> h_kwCOST_LABEL +| KwCOND -> h_kwCOND +| KwCALL -> h_kwCALL +| KwGOTO -> h_kwGOTO +| KwRETURN -> h_kwRETURN +| KwTAILCALL -> h_kwTAILCALL +| KwFCOND -> h_kwFCOND + +(** val keyword_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 **) +let rec keyword_rect_Type0 h_kwCOMMENT h_kwMOVE h_kwPOP h_kwPUSH h_kwADDRESS h_kwOPACCS h_kwOP1 h_kwOP2 h_kwCLEAR_CARRY h_kwSET_CARRY h_kwLOAD h_kwSTORE h_kwCOST_LABEL h_kwCOND h_kwCALL h_kwGOTO h_kwRETURN h_kwTAILCALL h_kwFCOND = function +| KwCOMMENT -> h_kwCOMMENT +| KwMOVE -> h_kwMOVE +| KwPOP -> h_kwPOP +| KwPUSH -> h_kwPUSH +| KwADDRESS -> h_kwADDRESS +| KwOPACCS -> h_kwOPACCS +| KwOP1 -> h_kwOP1 +| KwOP2 -> h_kwOP2 +| KwCLEAR_CARRY -> h_kwCLEAR_CARRY +| KwSET_CARRY -> h_kwSET_CARRY +| KwLOAD -> h_kwLOAD +| KwSTORE -> h_kwSTORE +| KwCOST_LABEL -> h_kwCOST_LABEL +| KwCOND -> h_kwCOND +| KwCALL -> h_kwCALL +| KwGOTO -> h_kwGOTO +| KwRETURN -> h_kwRETURN +| KwTAILCALL -> h_kwTAILCALL +| KwFCOND -> h_kwFCOND + +(** val keyword_inv_rect_Type4 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let keyword_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + keyword_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val keyword_inv_rect_Type3 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let keyword_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + keyword_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val keyword_inv_rect_Type2 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let keyword_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + keyword_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val keyword_inv_rect_Type1 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let keyword_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + keyword_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val keyword_inv_rect_Type0 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let keyword_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + keyword_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val keyword_discr : keyword -> keyword -> __ **) +let keyword_discr x y = + Logic.eq_rect_Type2 x + (match x with + | KwCOMMENT -> Obj.magic (fun _ dH -> dH) + | KwMOVE -> Obj.magic (fun _ dH -> dH) + | KwPOP -> Obj.magic (fun _ dH -> dH) + | KwPUSH -> Obj.magic (fun _ dH -> dH) + | KwADDRESS -> Obj.magic (fun _ dH -> dH) + | KwOPACCS -> Obj.magic (fun _ dH -> dH) + | KwOP1 -> Obj.magic (fun _ dH -> dH) + | KwOP2 -> Obj.magic (fun _ dH -> dH) + | KwCLEAR_CARRY -> Obj.magic (fun _ dH -> dH) + | KwSET_CARRY -> Obj.magic (fun _ dH -> dH) + | KwLOAD -> Obj.magic (fun _ dH -> dH) + | KwSTORE -> Obj.magic (fun _ dH -> dH) + | KwCOST_LABEL -> Obj.magic (fun _ dH -> dH) + | KwCOND -> Obj.magic (fun _ dH -> dH) + | KwCALL -> Obj.magic (fun _ dH -> dH) + | KwGOTO -> Obj.magic (fun _ dH -> dH) + | KwRETURN -> Obj.magic (fun _ dH -> dH) + | KwTAILCALL -> Obj.magic (fun _ dH -> dH) + | KwFCOND -> Obj.magic (fun _ dH -> dH)) y + +(** val keyword_jmdiscr : keyword -> keyword -> __ **) +let keyword_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | KwCOMMENT -> Obj.magic (fun _ dH -> dH) + | KwMOVE -> Obj.magic (fun _ dH -> dH) + | KwPOP -> Obj.magic (fun _ dH -> dH) + | KwPUSH -> Obj.magic (fun _ dH -> dH) + | KwADDRESS -> Obj.magic (fun _ dH -> dH) + | KwOPACCS -> Obj.magic (fun _ dH -> dH) + | KwOP1 -> Obj.magic (fun _ dH -> dH) + | KwOP2 -> Obj.magic (fun _ dH -> dH) + | KwCLEAR_CARRY -> Obj.magic (fun _ dH -> dH) + | KwSET_CARRY -> Obj.magic (fun _ dH -> dH) + | KwLOAD -> Obj.magic (fun _ dH -> dH) + | KwSTORE -> Obj.magic (fun _ dH -> dH) + | KwCOST_LABEL -> Obj.magic (fun _ dH -> dH) + | KwCOND -> Obj.magic (fun _ dH -> dH) + | KwCALL -> Obj.magic (fun _ dH -> dH) + | KwGOTO -> Obj.magic (fun _ dH -> dH) + | KwRETURN -> Obj.magic (fun _ dH -> dH) + | KwTAILCALL -> Obj.magic (fun _ dH -> dH) + | KwFCOND -> Obj.magic (fun _ dH -> dH)) y + +type 'string printing_pass_independent_params = { print_String : (String.string + -> 'string); + print_keyword : (keyword -> + 'string); + print_concat : ('string -> + 'string -> + 'string); + print_empty : 'string; + print_ident : (AST.ident -> + 'string); + print_costlabel : (CostLabel.costlabel + -> + 'string); + print_label : (Graphs.label + -> 'string); + print_OpAccs : (BackEndOps.opAccs + -> 'string); + print_Op1 : (BackEndOps.op1 + -> 'string); + print_Op2 : (BackEndOps.op2 + -> 'string); + print_nat : (Nat.nat -> + 'string); + print_bitvector : (Nat.nat + -> + BitVector.bitVector + -> + 'string) } + +(** val printing_pass_independent_params_rect_Type4 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 + printing_pass_independent_params -> 'a2 **) +let rec printing_pass_independent_params_rect_Type4 h_mk_printing_pass_independent_params x_263 = + let { print_String = print_String0; print_keyword = print_keyword0; + print_concat = print_concat0; print_empty = print_empty0; print_ident = + print_ident0; print_costlabel = print_costlabel0; print_label = + print_label0; print_OpAccs = print_OpAccs0; print_Op1 = print_Op3; + print_Op2 = print_Op4; print_nat = print_nat0; print_bitvector = + print_bitvector0 } = x_263 + in + h_mk_printing_pass_independent_params print_String0 print_keyword0 + print_concat0 print_empty0 print_ident0 print_costlabel0 print_label0 + print_OpAccs0 print_Op3 print_Op4 print_nat0 print_bitvector0 + +(** val printing_pass_independent_params_rect_Type5 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 + printing_pass_independent_params -> 'a2 **) +let rec printing_pass_independent_params_rect_Type5 h_mk_printing_pass_independent_params x_265 = + let { print_String = print_String0; print_keyword = print_keyword0; + print_concat = print_concat0; print_empty = print_empty0; print_ident = + print_ident0; print_costlabel = print_costlabel0; print_label = + print_label0; print_OpAccs = print_OpAccs0; print_Op1 = print_Op3; + print_Op2 = print_Op4; print_nat = print_nat0; print_bitvector = + print_bitvector0 } = x_265 + in + h_mk_printing_pass_independent_params print_String0 print_keyword0 + print_concat0 print_empty0 print_ident0 print_costlabel0 print_label0 + print_OpAccs0 print_Op3 print_Op4 print_nat0 print_bitvector0 + +(** val printing_pass_independent_params_rect_Type3 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 + printing_pass_independent_params -> 'a2 **) +let rec printing_pass_independent_params_rect_Type3 h_mk_printing_pass_independent_params x_267 = + let { print_String = print_String0; print_keyword = print_keyword0; + print_concat = print_concat0; print_empty = print_empty0; print_ident = + print_ident0; print_costlabel = print_costlabel0; print_label = + print_label0; print_OpAccs = print_OpAccs0; print_Op1 = print_Op3; + print_Op2 = print_Op4; print_nat = print_nat0; print_bitvector = + print_bitvector0 } = x_267 + in + h_mk_printing_pass_independent_params print_String0 print_keyword0 + print_concat0 print_empty0 print_ident0 print_costlabel0 print_label0 + print_OpAccs0 print_Op3 print_Op4 print_nat0 print_bitvector0 + +(** val printing_pass_independent_params_rect_Type2 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 + printing_pass_independent_params -> 'a2 **) +let rec printing_pass_independent_params_rect_Type2 h_mk_printing_pass_independent_params x_269 = + let { print_String = print_String0; print_keyword = print_keyword0; + print_concat = print_concat0; print_empty = print_empty0; print_ident = + print_ident0; print_costlabel = print_costlabel0; print_label = + print_label0; print_OpAccs = print_OpAccs0; print_Op1 = print_Op3; + print_Op2 = print_Op4; print_nat = print_nat0; print_bitvector = + print_bitvector0 } = x_269 + in + h_mk_printing_pass_independent_params print_String0 print_keyword0 + print_concat0 print_empty0 print_ident0 print_costlabel0 print_label0 + print_OpAccs0 print_Op3 print_Op4 print_nat0 print_bitvector0 + +(** val printing_pass_independent_params_rect_Type1 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 + printing_pass_independent_params -> 'a2 **) +let rec printing_pass_independent_params_rect_Type1 h_mk_printing_pass_independent_params x_271 = + let { print_String = print_String0; print_keyword = print_keyword0; + print_concat = print_concat0; print_empty = print_empty0; print_ident = + print_ident0; print_costlabel = print_costlabel0; print_label = + print_label0; print_OpAccs = print_OpAccs0; print_Op1 = print_Op3; + print_Op2 = print_Op4; print_nat = print_nat0; print_bitvector = + print_bitvector0 } = x_271 + in + h_mk_printing_pass_independent_params print_String0 print_keyword0 + print_concat0 print_empty0 print_ident0 print_costlabel0 print_label0 + print_OpAccs0 print_Op3 print_Op4 print_nat0 print_bitvector0 + +(** val printing_pass_independent_params_rect_Type0 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 + printing_pass_independent_params -> 'a2 **) +let rec printing_pass_independent_params_rect_Type0 h_mk_printing_pass_independent_params x_273 = + let { print_String = print_String0; print_keyword = print_keyword0; + print_concat = print_concat0; print_empty = print_empty0; print_ident = + print_ident0; print_costlabel = print_costlabel0; print_label = + print_label0; print_OpAccs = print_OpAccs0; print_Op1 = print_Op3; + print_Op2 = print_Op4; print_nat = print_nat0; print_bitvector = + print_bitvector0 } = x_273 + in + h_mk_printing_pass_independent_params print_String0 print_keyword0 + print_concat0 print_empty0 print_ident0 print_costlabel0 print_label0 + print_OpAccs0 print_Op3 print_Op4 print_nat0 print_bitvector0 + +(** val print_String : + 'a1 printing_pass_independent_params -> String.string -> 'a1 **) +let rec print_String xxx = + xxx.print_String + +(** val print_keyword : + 'a1 printing_pass_independent_params -> keyword -> 'a1 **) +let rec print_keyword xxx = + xxx.print_keyword + +(** val print_concat : + 'a1 printing_pass_independent_params -> 'a1 -> 'a1 -> 'a1 **) +let rec print_concat xxx = + xxx.print_concat + +(** val print_empty : 'a1 printing_pass_independent_params -> 'a1 **) +let rec print_empty xxx = + xxx.print_empty + +(** val print_ident : + 'a1 printing_pass_independent_params -> AST.ident -> 'a1 **) +let rec print_ident xxx = + xxx.print_ident + +(** val print_costlabel : + 'a1 printing_pass_independent_params -> CostLabel.costlabel -> 'a1 **) +let rec print_costlabel xxx = + xxx.print_costlabel + +(** val print_label : + 'a1 printing_pass_independent_params -> Graphs.label -> 'a1 **) +let rec print_label xxx = + xxx.print_label + +(** val print_OpAccs : + 'a1 printing_pass_independent_params -> BackEndOps.opAccs -> 'a1 **) +let rec print_OpAccs xxx = + xxx.print_OpAccs + +(** val print_Op1 : + 'a1 printing_pass_independent_params -> BackEndOps.op1 -> 'a1 **) +let rec print_Op1 xxx = + xxx.print_Op1 + +(** val print_Op2 : + 'a1 printing_pass_independent_params -> BackEndOps.op2 -> 'a1 **) +let rec print_Op2 xxx = + xxx.print_Op2 + +(** val print_nat : + 'a1 printing_pass_independent_params -> Nat.nat -> 'a1 **) +let rec print_nat xxx = + xxx.print_nat + +(** val print_bitvector : + 'a1 printing_pass_independent_params -> Nat.nat -> BitVector.bitVector -> + 'a1 **) +let rec print_bitvector xxx = + xxx.print_bitvector + +(** val printing_pass_independent_params_inv_rect_Type4 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> + (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> + (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 + -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> + __ -> 'a2) -> 'a2 **) +let printing_pass_independent_params_inv_rect_Type4 hterm h1 = + let hcut = printing_pass_independent_params_rect_Type4 h1 hterm in hcut __ + +(** val printing_pass_independent_params_inv_rect_Type3 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> + (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> + (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 + -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> + __ -> 'a2) -> 'a2 **) +let printing_pass_independent_params_inv_rect_Type3 hterm h1 = + let hcut = printing_pass_independent_params_rect_Type3 h1 hterm in hcut __ + +(** val printing_pass_independent_params_inv_rect_Type2 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> + (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> + (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 + -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> + __ -> 'a2) -> 'a2 **) +let printing_pass_independent_params_inv_rect_Type2 hterm h1 = + let hcut = printing_pass_independent_params_rect_Type2 h1 hterm in hcut __ + +(** val printing_pass_independent_params_inv_rect_Type1 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> + (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> + (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 + -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> + __ -> 'a2) -> 'a2 **) +let printing_pass_independent_params_inv_rect_Type1 hterm h1 = + let hcut = printing_pass_independent_params_rect_Type1 h1 hterm in hcut __ + +(** val printing_pass_independent_params_inv_rect_Type0 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> + (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> + (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 + -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> + __ -> 'a2) -> 'a2 **) +let printing_pass_independent_params_inv_rect_Type0 hterm h1 = + let hcut = printing_pass_independent_params_rect_Type0 h1 hterm in hcut __ + +(** val printing_pass_independent_params_jmdiscr : + 'a1 printing_pass_independent_params -> 'a1 + printing_pass_independent_params -> __ **) +let printing_pass_independent_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { print_String = a0; print_keyword = a10; print_concat = a2; + print_empty = a3; print_ident = a4; print_costlabel = a5; + print_label = a6; print_OpAccs = a7; print_Op1 = a8; print_Op2 = a9; + print_nat = a100; print_bitvector = a11 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __ __)) y + +type 'string printing_params = { print_pass_ind : 'string + printing_pass_independent_params; + print_acc_a_reg : (__ -> 'string); + print_acc_b_reg : (__ -> 'string); + print_acc_a_arg : (__ -> 'string); + print_acc_b_arg : (__ -> 'string); + print_dpl_reg : (__ -> 'string); + print_dph_reg : (__ -> 'string); + print_dpl_arg : (__ -> 'string); + print_dph_arg : (__ -> 'string); + print_snd_arg : (__ -> 'string); + print_pair_move : (__ -> 'string); + print_call_args : (__ -> 'string); + print_call_dest : (__ -> 'string); + print_ext_seq : (__ -> 'string) } + +(** val printing_params_rect_Type4 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + printing_params -> 'a2 **) +let rec printing_params_rect_Type4 p h_mk_printing_params x_301 = + let { print_pass_ind = print_pass_ind0; print_acc_a_reg = print_acc_a_reg0; + print_acc_b_reg = print_acc_b_reg0; print_acc_a_arg = print_acc_a_arg0; + print_acc_b_arg = print_acc_b_arg0; print_dpl_reg = print_dpl_reg0; + print_dph_reg = print_dph_reg0; print_dpl_arg = print_dpl_arg0; + print_dph_arg = print_dph_arg0; print_snd_arg = print_snd_arg0; + print_pair_move = print_pair_move0; print_call_args = print_call_args0; + print_call_dest = print_call_dest0; print_ext_seq = print_ext_seq0 } = + x_301 + in + h_mk_printing_params print_pass_ind0 print_acc_a_reg0 print_acc_b_reg0 + print_acc_a_arg0 print_acc_b_arg0 print_dpl_reg0 print_dph_reg0 + print_dpl_arg0 print_dph_arg0 print_snd_arg0 print_pair_move0 + print_call_args0 print_call_dest0 print_ext_seq0 + +(** val printing_params_rect_Type5 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + printing_params -> 'a2 **) +let rec printing_params_rect_Type5 p h_mk_printing_params x_303 = + let { print_pass_ind = print_pass_ind0; print_acc_a_reg = print_acc_a_reg0; + print_acc_b_reg = print_acc_b_reg0; print_acc_a_arg = print_acc_a_arg0; + print_acc_b_arg = print_acc_b_arg0; print_dpl_reg = print_dpl_reg0; + print_dph_reg = print_dph_reg0; print_dpl_arg = print_dpl_arg0; + print_dph_arg = print_dph_arg0; print_snd_arg = print_snd_arg0; + print_pair_move = print_pair_move0; print_call_args = print_call_args0; + print_call_dest = print_call_dest0; print_ext_seq = print_ext_seq0 } = + x_303 + in + h_mk_printing_params print_pass_ind0 print_acc_a_reg0 print_acc_b_reg0 + print_acc_a_arg0 print_acc_b_arg0 print_dpl_reg0 print_dph_reg0 + print_dpl_arg0 print_dph_arg0 print_snd_arg0 print_pair_move0 + print_call_args0 print_call_dest0 print_ext_seq0 + +(** val printing_params_rect_Type3 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + printing_params -> 'a2 **) +let rec printing_params_rect_Type3 p h_mk_printing_params x_305 = + let { print_pass_ind = print_pass_ind0; print_acc_a_reg = print_acc_a_reg0; + print_acc_b_reg = print_acc_b_reg0; print_acc_a_arg = print_acc_a_arg0; + print_acc_b_arg = print_acc_b_arg0; print_dpl_reg = print_dpl_reg0; + print_dph_reg = print_dph_reg0; print_dpl_arg = print_dpl_arg0; + print_dph_arg = print_dph_arg0; print_snd_arg = print_snd_arg0; + print_pair_move = print_pair_move0; print_call_args = print_call_args0; + print_call_dest = print_call_dest0; print_ext_seq = print_ext_seq0 } = + x_305 + in + h_mk_printing_params print_pass_ind0 print_acc_a_reg0 print_acc_b_reg0 + print_acc_a_arg0 print_acc_b_arg0 print_dpl_reg0 print_dph_reg0 + print_dpl_arg0 print_dph_arg0 print_snd_arg0 print_pair_move0 + print_call_args0 print_call_dest0 print_ext_seq0 + +(** val printing_params_rect_Type2 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + printing_params -> 'a2 **) +let rec printing_params_rect_Type2 p h_mk_printing_params x_307 = + let { print_pass_ind = print_pass_ind0; print_acc_a_reg = print_acc_a_reg0; + print_acc_b_reg = print_acc_b_reg0; print_acc_a_arg = print_acc_a_arg0; + print_acc_b_arg = print_acc_b_arg0; print_dpl_reg = print_dpl_reg0; + print_dph_reg = print_dph_reg0; print_dpl_arg = print_dpl_arg0; + print_dph_arg = print_dph_arg0; print_snd_arg = print_snd_arg0; + print_pair_move = print_pair_move0; print_call_args = print_call_args0; + print_call_dest = print_call_dest0; print_ext_seq = print_ext_seq0 } = + x_307 + in + h_mk_printing_params print_pass_ind0 print_acc_a_reg0 print_acc_b_reg0 + print_acc_a_arg0 print_acc_b_arg0 print_dpl_reg0 print_dph_reg0 + print_dpl_arg0 print_dph_arg0 print_snd_arg0 print_pair_move0 + print_call_args0 print_call_dest0 print_ext_seq0 + +(** val printing_params_rect_Type1 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + printing_params -> 'a2 **) +let rec printing_params_rect_Type1 p h_mk_printing_params x_309 = + let { print_pass_ind = print_pass_ind0; print_acc_a_reg = print_acc_a_reg0; + print_acc_b_reg = print_acc_b_reg0; print_acc_a_arg = print_acc_a_arg0; + print_acc_b_arg = print_acc_b_arg0; print_dpl_reg = print_dpl_reg0; + print_dph_reg = print_dph_reg0; print_dpl_arg = print_dpl_arg0; + print_dph_arg = print_dph_arg0; print_snd_arg = print_snd_arg0; + print_pair_move = print_pair_move0; print_call_args = print_call_args0; + print_call_dest = print_call_dest0; print_ext_seq = print_ext_seq0 } = + x_309 + in + h_mk_printing_params print_pass_ind0 print_acc_a_reg0 print_acc_b_reg0 + print_acc_a_arg0 print_acc_b_arg0 print_dpl_reg0 print_dph_reg0 + print_dpl_arg0 print_dph_arg0 print_snd_arg0 print_pair_move0 + print_call_args0 print_call_dest0 print_ext_seq0 + +(** val printing_params_rect_Type0 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + printing_params -> 'a2 **) +let rec printing_params_rect_Type0 p h_mk_printing_params x_311 = + let { print_pass_ind = print_pass_ind0; print_acc_a_reg = print_acc_a_reg0; + print_acc_b_reg = print_acc_b_reg0; print_acc_a_arg = print_acc_a_arg0; + print_acc_b_arg = print_acc_b_arg0; print_dpl_reg = print_dpl_reg0; + print_dph_reg = print_dph_reg0; print_dpl_arg = print_dpl_arg0; + print_dph_arg = print_dph_arg0; print_snd_arg = print_snd_arg0; + print_pair_move = print_pair_move0; print_call_args = print_call_args0; + print_call_dest = print_call_dest0; print_ext_seq = print_ext_seq0 } = + x_311 + in + h_mk_printing_params print_pass_ind0 print_acc_a_reg0 print_acc_b_reg0 + print_acc_a_arg0 print_acc_b_arg0 print_dpl_reg0 print_dph_reg0 + print_dpl_arg0 print_dph_arg0 print_snd_arg0 print_pair_move0 + print_call_args0 print_call_dest0 print_ext_seq0 + +(** val print_pass_ind : + Joint.unserialized_params -> 'a1 printing_params -> 'a1 + printing_pass_independent_params **) +let rec print_pass_ind p xxx = + xxx.print_pass_ind + +(** val print_acc_a_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_acc_a_reg p xxx = + xxx.print_acc_a_reg + +(** val print_acc_b_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_acc_b_reg p xxx = + xxx.print_acc_b_reg + +(** val print_acc_a_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_acc_a_arg p xxx = + xxx.print_acc_a_arg + +(** val print_acc_b_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_acc_b_arg p xxx = + xxx.print_acc_b_arg + +(** val print_dpl_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_dpl_reg p xxx = + xxx.print_dpl_reg + +(** val print_dph_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_dph_reg p xxx = + xxx.print_dph_reg + +(** val print_dpl_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_dpl_arg p xxx = + xxx.print_dpl_arg + +(** val print_dph_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_dph_arg p xxx = + xxx.print_dph_arg + +(** val print_snd_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_snd_arg p xxx = + xxx.print_snd_arg + +(** val print_pair_move : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_pair_move p xxx = + xxx.print_pair_move + +(** val print_call_args : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_call_args p xxx = + xxx.print_call_args + +(** val print_call_dest : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_call_dest p xxx = + xxx.print_call_dest + +(** val print_ext_seq : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 **) +let rec print_ext_seq p xxx = + xxx.print_ext_seq + +(** val printing_params_inv_rect_Type4 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a2) -> 'a2 **) +let printing_params_inv_rect_Type4 x2 hterm h1 = + let hcut = printing_params_rect_Type4 x2 h1 hterm in hcut __ + +(** val printing_params_inv_rect_Type3 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a2) -> 'a2 **) +let printing_params_inv_rect_Type3 x2 hterm h1 = + let hcut = printing_params_rect_Type3 x2 h1 hterm in hcut __ + +(** val printing_params_inv_rect_Type2 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a2) -> 'a2 **) +let printing_params_inv_rect_Type2 x2 hterm h1 = + let hcut = printing_params_rect_Type2 x2 h1 hterm in hcut __ + +(** val printing_params_inv_rect_Type1 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a2) -> 'a2 **) +let printing_params_inv_rect_Type1 x2 hterm h1 = + let hcut = printing_params_rect_Type1 x2 h1 hterm in hcut __ + +(** val printing_params_inv_rect_Type0 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> __ -> 'a2) -> 'a2 **) +let printing_params_inv_rect_Type0 x2 hterm h1 = + let hcut = printing_params_rect_Type0 x2 h1 hterm in hcut __ + +(** val printing_params_jmdiscr : + Joint.unserialized_params -> 'a1 printing_params -> 'a1 printing_params + -> __ **) +let printing_params_jmdiscr a2 x y = + Logic.eq_rect_Type2 x + (let { print_pass_ind = a0; print_acc_a_reg = a10; print_acc_b_reg = a20; + print_acc_a_arg = a3; print_acc_b_arg = a4; print_dpl_reg = a5; + print_dph_reg = a6; print_dpl_arg = a7; print_dph_arg = a8; + print_snd_arg = a9; print_pair_move = a100; print_call_args = a11; + print_call_dest = a12; print_ext_seq = a13 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __ __ __ __)) y + +(** val dpi1__o__print_pass_ind__o__inject : + Joint.unserialized_params -> ('a1 printing_params, 'a2) Types.dPair -> + 'a1 printing_pass_independent_params Types.sig0 **) +let dpi1__o__print_pass_ind__o__inject x1 x4 = + x4.Types.dpi1.print_pass_ind + +(** val eject__o__print_pass_ind__o__inject : + Joint.unserialized_params -> 'a1 printing_params Types.sig0 -> 'a1 + printing_pass_independent_params Types.sig0 **) +let eject__o__print_pass_ind__o__inject x1 x4 = + (Types.pi1 x4).print_pass_ind + +(** val print_pass_ind__o__inject : + Joint.unserialized_params -> 'a1 printing_params -> 'a1 + printing_pass_independent_params Types.sig0 **) +let print_pass_ind__o__inject x1 x3 = + x3.print_pass_ind + +(** val dpi1__o__print_pass_ind : + Joint.unserialized_params -> ('a1 printing_params, 'a2) Types.dPair -> + 'a1 printing_pass_independent_params **) +let dpi1__o__print_pass_ind x1 x3 = + x3.Types.dpi1.print_pass_ind + +(** val eject__o__print_pass_ind : + Joint.unserialized_params -> 'a1 printing_params Types.sig0 -> 'a1 + printing_pass_independent_params **) +let eject__o__print_pass_ind x1 x3 = + (Types.pi1 x3).print_pass_ind + +type 'string print_serialization_params = { print_succ : (__ -> 'string); + print_code_point : (__ -> + 'string) } + +(** val print_serialization_params_rect_Type4 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 **) +let rec print_serialization_params_rect_Type4 p h_mk_print_serialization_params x_340 = + let { print_succ = print_succ0; print_code_point = print_code_point0 } = + x_340 + in + h_mk_print_serialization_params print_succ0 print_code_point0 + +(** val print_serialization_params_rect_Type5 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 **) +let rec print_serialization_params_rect_Type5 p h_mk_print_serialization_params x_342 = + let { print_succ = print_succ0; print_code_point = print_code_point0 } = + x_342 + in + h_mk_print_serialization_params print_succ0 print_code_point0 + +(** val print_serialization_params_rect_Type3 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 **) +let rec print_serialization_params_rect_Type3 p h_mk_print_serialization_params x_344 = + let { print_succ = print_succ0; print_code_point = print_code_point0 } = + x_344 + in + h_mk_print_serialization_params print_succ0 print_code_point0 + +(** val print_serialization_params_rect_Type2 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 **) +let rec print_serialization_params_rect_Type2 p h_mk_print_serialization_params x_346 = + let { print_succ = print_succ0; print_code_point = print_code_point0 } = + x_346 + in + h_mk_print_serialization_params print_succ0 print_code_point0 + +(** val print_serialization_params_rect_Type1 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 **) +let rec print_serialization_params_rect_Type1 p h_mk_print_serialization_params x_348 = + let { print_succ = print_succ0; print_code_point = print_code_point0 } = + x_348 + in + h_mk_print_serialization_params print_succ0 print_code_point0 + +(** val print_serialization_params_rect_Type0 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 **) +let rec print_serialization_params_rect_Type0 p h_mk_print_serialization_params x_350 = + let { print_succ = print_succ0; print_code_point = print_code_point0 } = + x_350 + in + h_mk_print_serialization_params print_succ0 print_code_point0 + +(** val print_succ : + Joint.params -> 'a1 print_serialization_params -> __ -> 'a1 **) +let rec print_succ p xxx = + xxx.print_succ + +(** val print_code_point : + Joint.params -> 'a1 print_serialization_params -> __ -> 'a1 **) +let rec print_code_point p xxx = + xxx.print_code_point + +(** val print_serialization_params_inv_rect_Type4 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 **) +let print_serialization_params_inv_rect_Type4 x2 hterm h1 = + let hcut = print_serialization_params_rect_Type4 x2 h1 hterm in hcut __ + +(** val print_serialization_params_inv_rect_Type3 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 **) +let print_serialization_params_inv_rect_Type3 x2 hterm h1 = + let hcut = print_serialization_params_rect_Type3 x2 h1 hterm in hcut __ + +(** val print_serialization_params_inv_rect_Type2 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 **) +let print_serialization_params_inv_rect_Type2 x2 hterm h1 = + let hcut = print_serialization_params_rect_Type2 x2 h1 hterm in hcut __ + +(** val print_serialization_params_inv_rect_Type1 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 **) +let print_serialization_params_inv_rect_Type1 x2 hterm h1 = + let hcut = print_serialization_params_rect_Type1 x2 h1 hterm in hcut __ + +(** val print_serialization_params_inv_rect_Type0 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 **) +let print_serialization_params_inv_rect_Type0 x2 hterm h1 = + let hcut = print_serialization_params_rect_Type0 x2 h1 hterm in hcut __ + +(** val print_serialization_params_discr : + Joint.params -> 'a1 print_serialization_params -> 'a1 + print_serialization_params -> __ **) +let print_serialization_params_discr a2 x y = + Logic.eq_rect_Type2 x + (let { print_succ = a0; print_code_point = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val print_serialization_params_jmdiscr : + Joint.params -> 'a1 print_serialization_params -> 'a1 + print_serialization_params -> __ **) +let print_serialization_params_jmdiscr a2 x y = + Logic.eq_rect_Type2 x + (let { print_succ = a0; print_code_point = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +type ('string, 'statementT) code_iteration_params = { cip_print_serialization_params : + 'string + print_serialization_params; + fold_code : (__ -> (__ + -> + 'statementT + -> __ -> + __) -> __ + -> __ -> __ + -> __); + print_statementT : + ('statementT -> + 'string) } + +(** val code_iteration_params_rect_Type4 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) + -> 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 **) +let rec code_iteration_params_rect_Type4 p globals h_mk_code_iteration_params x_368 = + let { cip_print_serialization_params = cip_print_serialization_params0; + fold_code = fold_code0; print_statementT = print_statementT0 } = x_368 + in + h_mk_code_iteration_params cip_print_serialization_params0 fold_code0 + print_statementT0 + +(** val code_iteration_params_rect_Type5 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) + -> 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 **) +let rec code_iteration_params_rect_Type5 p globals h_mk_code_iteration_params x_370 = + let { cip_print_serialization_params = cip_print_serialization_params0; + fold_code = fold_code0; print_statementT = print_statementT0 } = x_370 + in + h_mk_code_iteration_params cip_print_serialization_params0 fold_code0 + print_statementT0 + +(** val code_iteration_params_rect_Type3 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) + -> 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 **) +let rec code_iteration_params_rect_Type3 p globals h_mk_code_iteration_params x_372 = + let { cip_print_serialization_params = cip_print_serialization_params0; + fold_code = fold_code0; print_statementT = print_statementT0 } = x_372 + in + h_mk_code_iteration_params cip_print_serialization_params0 fold_code0 + print_statementT0 + +(** val code_iteration_params_rect_Type2 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) + -> 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 **) +let rec code_iteration_params_rect_Type2 p globals h_mk_code_iteration_params x_374 = + let { cip_print_serialization_params = cip_print_serialization_params0; + fold_code = fold_code0; print_statementT = print_statementT0 } = x_374 + in + h_mk_code_iteration_params cip_print_serialization_params0 fold_code0 + print_statementT0 + +(** val code_iteration_params_rect_Type1 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) + -> 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 **) +let rec code_iteration_params_rect_Type1 p globals h_mk_code_iteration_params x_376 = + let { cip_print_serialization_params = cip_print_serialization_params0; + fold_code = fold_code0; print_statementT = print_statementT0 } = x_376 + in + h_mk_code_iteration_params cip_print_serialization_params0 fold_code0 + print_statementT0 + +(** val code_iteration_params_rect_Type0 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) + -> 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 **) +let rec code_iteration_params_rect_Type0 p globals h_mk_code_iteration_params x_378 = + let { cip_print_serialization_params = cip_print_serialization_params0; + fold_code = fold_code0; print_statementT = print_statementT0 } = x_378 + in + h_mk_code_iteration_params cip_print_serialization_params0 fold_code0 + print_statementT0 + +(** val cip_print_serialization_params : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> 'a1 print_serialization_params **) +let rec cip_print_serialization_params p globals xxx = + xxx.cip_print_serialization_params + +(** val fold_code0 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> (__ -> 'a2 -> 'a3 -> 'a3) -> __ -> __ -> 'a3 -> 'a3 **) +let rec fold_code0 p globals xxx x_393 x_394 x_395 x_396 = + (let { cip_print_serialization_params = x; fold_code = yyy; + print_statementT = x0 } = xxx + in + Obj.magic yyy) __ x_393 x_394 x_395 x_396 + +(** val print_statementT : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> 'a2 -> 'a1 **) +let rec print_statementT p globals xxx = + xxx.print_statementT + +(** val code_iteration_params_inv_rect_Type4 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> + __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 **) +let code_iteration_params_inv_rect_Type4 x2 x4 hterm h1 = + let hcut = code_iteration_params_rect_Type4 x2 x4 h1 hterm in hcut __ + +(** val code_iteration_params_inv_rect_Type3 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> + __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 **) +let code_iteration_params_inv_rect_Type3 x2 x4 hterm h1 = + let hcut = code_iteration_params_rect_Type3 x2 x4 h1 hterm in hcut __ + +(** val code_iteration_params_inv_rect_Type2 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> + __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 **) +let code_iteration_params_inv_rect_Type2 x2 x4 hterm h1 = + let hcut = code_iteration_params_rect_Type2 x2 x4 h1 hterm in hcut __ + +(** val code_iteration_params_inv_rect_Type1 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> + __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 **) +let code_iteration_params_inv_rect_Type1 x2 x4 hterm h1 = + let hcut = code_iteration_params_rect_Type1 x2 x4 h1 hterm in hcut __ + +(** val code_iteration_params_inv_rect_Type0 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> + __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 **) +let code_iteration_params_inv_rect_Type0 x2 x4 hterm h1 = + let hcut = code_iteration_params_rect_Type0 x2 x4 h1 hterm in hcut __ + +(** val code_iteration_params_jmdiscr : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params + -> ('a1, 'a2) code_iteration_params -> __ **) +let code_iteration_params_jmdiscr a2 a4 x y = + Logic.eq_rect_Type2 x + (let { cip_print_serialization_params = a0; fold_code = a10; + print_statementT = a20 } = x + in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val pm_choose_with_pref : + 'a1 PositiveMap.positive_map -> Positive.pos Types.option -> + ((Positive.pos, 'a1) Types.prod, 'a1 PositiveMap.positive_map) Types.prod + Types.option **) +let pm_choose_with_pref m = function +| Types.None -> PositiveMap.pm_choose m +| Types.Some p -> + (match PositiveMap.pm_try_remove p m with + | Types.None -> PositiveMap.pm_choose m + | Types.Some res -> + let { Types.fst = a; Types.snd = m' } = res in + Types.Some { Types.fst = { Types.fst = p; Types.snd = a }; Types.snd = + m' }) + +(** val visit_graph : + ('a1 -> Positive.pos Types.option) -> (Positive.pos -> 'a1 -> 'a2 -> 'a2) + -> 'a2 -> Positive.pos Types.option -> 'a1 PositiveMap.positive_map -> + Nat.nat -> 'a2 **) +let rec visit_graph next f b n m = function +| Nat.O -> b +| Nat.S y -> + (match pm_choose_with_pref m n with + | Types.None -> b + | Types.Some res -> + let { Types.fst = eta2; Types.snd = m' } = res in + let { Types.fst = pos; Types.snd = a } = eta2 in + visit_graph next f (f pos a b) (next a) m' y) + +(** val print_list : + 'a1 printing_pass_independent_params -> 'a1 List.list -> 'a1 **) +let print_list pp = + List.foldr pp.print_concat pp.print_empty + +(** val print_joint_seq : + Joint.unserialized_params -> AST.ident List.list -> 'a1 printing_params + -> Joint.joint_seq -> 'a1 **) +let print_joint_seq p globals pp = function +| Joint.COMMENT str -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwCOMMENT), (List.Cons + ((pp.print_pass_ind.print_String str), List.Nil)))) +| Joint.MOVE pm -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwMOVE), (List.Cons + ((pp.print_pair_move pm), List.Nil)))) +| Joint.POP arg -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwPOP), (List.Cons + ((pp.print_acc_a_reg arg), List.Nil)))) +| Joint.PUSH arg -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwPUSH), (List.Cons + ((pp.print_acc_a_arg arg), List.Nil)))) +| Joint.ADDRESS (i, offset, arg1, arg2) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwADDRESS), (List.Cons + ((pp.print_pass_ind.print_ident i), (List.Cons + ((pp.print_pass_ind.print_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) offset), (List.Cons + ((pp.print_dpl_reg arg1), (List.Cons ((pp.print_dph_reg arg2), + List.Nil)))))))))) +| Joint.OPACCS (opa, arg1, arg2, arg3, arg4) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwOPACCS), (List.Cons + ((pp.print_pass_ind.print_OpAccs opa), (List.Cons + ((pp.print_acc_a_reg arg1), (List.Cons ((pp.print_acc_b_reg arg2), + (List.Cons ((pp.print_acc_a_arg arg3), (List.Cons + ((pp.print_acc_b_arg arg4), List.Nil)))))))))))) +| Joint.OP1 (op1, arg1, arg2) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwOP1), (List.Cons + ((pp.print_pass_ind.print_Op1 op1), (List.Cons + ((pp.print_acc_a_reg arg1), (List.Cons ((pp.print_acc_a_reg arg2), + List.Nil)))))))) +| Joint.OP2 (op2, arg1, arg2, arg3) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwOP2), (List.Cons + ((pp.print_pass_ind.print_Op2 op2), (List.Cons + ((pp.print_acc_a_reg arg1), (List.Cons ((pp.print_acc_a_arg arg2), + (List.Cons ((pp.print_snd_arg arg3), List.Nil)))))))))) +| Joint.CLEAR_CARRY -> pp.print_pass_ind.print_keyword KwCLEAR_CARRY +| Joint.SET_CARRY -> pp.print_pass_ind.print_keyword KwSET_CARRY +| Joint.LOAD (arg1, arg2, arg3) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwLOAD), (List.Cons + ((pp.print_acc_a_reg arg1), (List.Cons ((pp.print_dpl_arg arg2), + (List.Cons ((pp.print_dph_arg arg3), List.Nil)))))))) +| Joint.STORE (arg1, arg2, arg3) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwSTORE), (List.Cons + ((pp.print_dpl_arg arg1), (List.Cons ((pp.print_dph_arg arg2), (List.Cons + ((pp.print_acc_a_arg arg3), List.Nil)))))))) +| Joint.Extension_seq ext -> pp.print_ext_seq ext + +(** val print_joint_step : + Joint.unserialized_params -> AST.ident List.list -> 'a1 printing_params + -> Joint.joint_step -> 'a1 **) +let print_joint_step p globals pp = function +| Joint.COST_LABEL arg -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwCOST_LABEL), (List.Cons + ((pp.print_pass_ind.print_costlabel arg), List.Nil)))) +| Joint.CALL (arg1, arg2, arg3) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwCALL), (List.Cons + ((match arg1 with + | Types.Inl id -> pp.print_pass_ind.print_ident id + | Types.Inr arg11_arg12 -> + pp.print_pass_ind.print_concat + (pp.print_dpl_arg arg11_arg12.Types.fst) + (pp.print_dph_arg arg11_arg12.Types.snd)), (List.Cons + ((pp.print_call_args arg2), (List.Cons ((pp.print_call_dest arg3), + List.Nil)))))))) +| Joint.COND (arg1, arg2) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwCOND), (List.Cons + ((pp.print_acc_a_reg arg1), (List.Cons + ((pp.print_pass_ind.print_label arg2), List.Nil)))))) +| Joint.Step_seq seq -> print_joint_seq p globals pp seq + +(** val print_joint_fin_step : + Joint.unserialized_params -> 'a1 printing_params -> Joint.joint_fin_step + -> 'a1 **) +let print_joint_fin_step p pp = function +| Joint.GOTO l -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwGOTO), (List.Cons + ((pp.print_pass_ind.print_label l), List.Nil)))) +| Joint.RETURN -> pp.print_pass_ind.print_keyword KwRETURN +| Joint.TAILCALL (arg1, arg2) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwTAILCALL), (List.Cons + ((match arg1 with + | Types.Inl id -> pp.print_pass_ind.print_ident id + | Types.Inr arg11_arg12 -> + pp.print_pass_ind.print_concat + (pp.print_dpl_arg arg11_arg12.Types.fst) + (pp.print_dph_arg arg11_arg12.Types.snd)), (List.Cons + ((pp.print_call_args arg2), List.Nil)))))) + +(** val print_joint_statement : + Joint.params -> AST.ident List.list -> 'a1 printing_params -> 'a1 + print_serialization_params -> Joint.joint_statement -> 'a1 **) +let print_joint_statement p globals pp cip = function +| Joint.Sequential (js, arg1) -> + pp.print_pass_ind.print_concat + (print_joint_step (Joint.stmt_pars__o__uns_pars__o__u_pars p) globals pp + js) (cip.print_succ arg1) +| Joint.Final fin -> + print_joint_fin_step (Joint.stmt_pars__o__uns_pars__o__u_pars p) pp fin +| Joint.FCOND (arg1, arg2, arg3) -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_keyword KwFCOND), (List.Cons + ((pp.print_acc_a_reg arg1), (List.Cons + ((pp.print_pass_ind.print_label arg2), (List.Cons + ((pp.print_pass_ind.print_label arg3), List.Nil)))))))) + +(** val graph_print_serialization_params : + Joint.graph_params -> 'a1 printing_params -> 'a1 + print_serialization_params **) +let graph_print_serialization_params gp pp = + { print_succ = (Obj.magic pp.print_pass_ind.print_label); + print_code_point = (Obj.magic pp.print_pass_ind.print_label) } + +(** val graph_code_iteration_params : + Joint.graph_params -> AST.ident List.list -> 'a1 printing_params -> ('a1, + Joint.joint_statement) code_iteration_params **) +let graph_code_iteration_params gp globals pp = + { cip_print_serialization_params = + (graph_print_serialization_params gp pp); fold_code = + (fun _ f m initl a -> + visit_graph (fun stmt -> + match Joint.stmt_implicit_label (Joint.gp_to_p__o__stmt_pars gp) + globals stmt with + | Types.None -> Types.None + | Types.Some label -> let p = label in Types.Some p) (fun n -> + Obj.magic f n) a (Types.Some + (Identifiers.word_of_identifier PreIdentifiers.LabelTag + (Obj.magic initl))) (let m' = Obj.magic m in m') + (Identifiers.id_map_size PreIdentifiers.LabelTag (Obj.magic m))); + print_statementT = + (print_joint_statement (Joint.graph_params_to_params gp) globals pp + (graph_print_serialization_params gp pp)) } + +(** val lin_print_serialization_params : + Joint.lin_params -> 'a1 printing_params -> 'a1 print_serialization_params **) +let lin_print_serialization_params gp pp = + { print_succ = (fun x -> pp.print_pass_ind.print_empty); print_code_point = + (Obj.magic pp.print_pass_ind.print_nat) } + +(** val lin_code_iteration_params : + Joint.lin_params -> AST.ident List.list -> 'a1 printing_params -> ('a1, + (Graphs.label Types.option, Joint.joint_statement) Types.prod) + code_iteration_params **) +let lin_code_iteration_params lp globals pp = + { cip_print_serialization_params = (lin_print_serialization_params lp pp); + fold_code = (fun _ f m x a -> + (Util.foldl (fun res x0 -> + let { Types.fst = pc; Types.snd = res' } = res in + { Types.fst = (Nat.S pc); Types.snd = (Obj.magic f pc x0 res') }) + { Types.fst = Nat.O; Types.snd = a } (Obj.magic m)).Types.snd); + print_statementT = (fun linstr -> + match linstr.Types.fst with + | Types.None -> + print_joint_statement (Joint.lin_params_to_params lp) globals pp + (lin_print_serialization_params lp pp) linstr.Types.snd + | Types.Some l -> + print_list pp.print_pass_ind (List.Cons + ((pp.print_pass_ind.print_label l), (List.Cons + ((print_joint_statement (Joint.lin_params_to_params lp) globals pp + (lin_print_serialization_params lp pp) linstr.Types.snd), + List.Nil))))) } + +(** val print_joint_internal_function : + Joint.params -> AST.ident List.list -> ('a2, 'a1) code_iteration_params + -> 'a2 printing_params -> Joint.joint_internal_function -> 'a2 List.list **) +let print_joint_internal_function p globals cip pp f = + fold_code0 p globals cip (fun cp stmt acc -> List.Cons + ((print_list pp.print_pass_ind (List.Cons + ((cip.cip_print_serialization_params.print_code_point cp), (List.Cons + ((cip.print_statementT stmt), List.Nil))))), acc)) + f.Joint.joint_if_code f.Joint.joint_if_entry List.Nil + +(** val print_joint_function : + Joint.params -> AST.ident List.list -> AST.ident List.list -> ('a2, 'a1) + code_iteration_params -> 'a2 printing_params -> Joint.joint_function -> + 'a2 List.list **) +let print_joint_function p globals functions cip pp = function +| AST.Internal f0 -> + print_joint_internal_function p (List.append globals functions) cip pp + (Types.pi1 f0) +| AST.External f0 -> List.Nil + +(** val print_joint_program : + Joint.params -> 'a2 printing_params -> Joint.joint_program -> ('a2, 'a1) + code_iteration_params -> (AST.ident, 'a2 List.list) Types.prod List.list **) +let print_joint_program p pp prog cip = + List.foldr (fun f acc -> List.Cons ({ Types.fst = f.Types.fst; Types.snd = + (print_joint_function p (AST.prog_var_names prog.Joint.joint_prog) + prog.Joint.jp_functions cip pp f.Types.snd) }, acc)) List.Nil + prog.Joint.joint_prog.AST.prog_funct + diff --git a/extracted/joint_printer.mli b/extracted/joint_printer.mli new file mode 100644 index 0000000..17bbe09 --- /dev/null +++ b/extracted/joint_printer.mli @@ -0,0 +1,700 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type keyword = +| KwCOMMENT +| KwMOVE +| KwPOP +| KwPUSH +| KwADDRESS +| KwOPACCS +| KwOP1 +| KwOP2 +| KwCLEAR_CARRY +| KwSET_CARRY +| KwLOAD +| KwSTORE +| KwCOST_LABEL +| KwCOND +| KwCALL +| KwGOTO +| KwRETURN +| KwTAILCALL +| KwFCOND + +val keyword_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 + +val keyword_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 + +val keyword_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 + +val keyword_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 + +val keyword_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 + +val keyword_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> keyword -> 'a1 + +val keyword_inv_rect_Type4 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val keyword_inv_rect_Type3 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val keyword_inv_rect_Type2 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val keyword_inv_rect_Type1 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val keyword_inv_rect_Type0 : + keyword -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val keyword_discr : keyword -> keyword -> __ + +val keyword_jmdiscr : keyword -> keyword -> __ + +type 'string printing_pass_independent_params = { print_String : (String.string + -> 'string); + print_keyword : (keyword -> + 'string); + print_concat : ('string -> + 'string -> + 'string); + print_empty : 'string; + print_ident : (AST.ident -> + 'string); + print_costlabel : (CostLabel.costlabel + -> + 'string); + print_label : (Graphs.label + -> 'string); + print_OpAccs : (BackEndOps.opAccs + -> 'string); + print_Op1 : (BackEndOps.op1 + -> 'string); + print_Op2 : (BackEndOps.op2 + -> 'string); + print_nat : (Nat.nat -> + 'string); + print_bitvector : (Nat.nat + -> + BitVector.bitVector + -> + 'string) } + +val printing_pass_independent_params_rect_Type4 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 printing_pass_independent_params + -> 'a2 + +val printing_pass_independent_params_rect_Type5 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 printing_pass_independent_params + -> 'a2 + +val printing_pass_independent_params_rect_Type3 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 printing_pass_independent_params + -> 'a2 + +val printing_pass_independent_params_rect_Type2 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 printing_pass_independent_params + -> 'a2 + +val printing_pass_independent_params_rect_Type1 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 printing_pass_independent_params + -> 'a2 + +val printing_pass_independent_params_rect_Type0 : + ((String.string -> 'a1) -> (keyword -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 + -> (AST.ident -> 'a1) -> (CostLabel.costlabel -> 'a1) -> (Graphs.label -> + 'a1) -> (BackEndOps.opAccs -> 'a1) -> (BackEndOps.op1 -> 'a1) -> + (BackEndOps.op2 -> 'a1) -> (Nat.nat -> 'a1) -> (Nat.nat -> + BitVector.bitVector -> 'a1) -> 'a2) -> 'a1 printing_pass_independent_params + -> 'a2 + +val print_String : + 'a1 printing_pass_independent_params -> String.string -> 'a1 + +val print_keyword : 'a1 printing_pass_independent_params -> keyword -> 'a1 + +val print_concat : 'a1 printing_pass_independent_params -> 'a1 -> 'a1 -> 'a1 + +val print_empty : 'a1 printing_pass_independent_params -> 'a1 + +val print_ident : 'a1 printing_pass_independent_params -> AST.ident -> 'a1 + +val print_costlabel : + 'a1 printing_pass_independent_params -> CostLabel.costlabel -> 'a1 + +val print_label : 'a1 printing_pass_independent_params -> Graphs.label -> 'a1 + +val print_OpAccs : + 'a1 printing_pass_independent_params -> BackEndOps.opAccs -> 'a1 + +val print_Op1 : 'a1 printing_pass_independent_params -> BackEndOps.op1 -> 'a1 + +val print_Op2 : 'a1 printing_pass_independent_params -> BackEndOps.op2 -> 'a1 + +val print_nat : 'a1 printing_pass_independent_params -> Nat.nat -> 'a1 + +val print_bitvector : + 'a1 printing_pass_independent_params -> Nat.nat -> BitVector.bitVector -> + 'a1 + +val printing_pass_independent_params_inv_rect_Type4 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> (keyword + -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> (BackEndOps.opAccs + -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 -> 'a1) -> (Nat.nat + -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> __ -> 'a2) -> 'a2 + +val printing_pass_independent_params_inv_rect_Type3 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> (keyword + -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> (BackEndOps.opAccs + -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 -> 'a1) -> (Nat.nat + -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> __ -> 'a2) -> 'a2 + +val printing_pass_independent_params_inv_rect_Type2 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> (keyword + -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> (BackEndOps.opAccs + -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 -> 'a1) -> (Nat.nat + -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> __ -> 'a2) -> 'a2 + +val printing_pass_independent_params_inv_rect_Type1 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> (keyword + -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> (BackEndOps.opAccs + -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 -> 'a1) -> (Nat.nat + -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> __ -> 'a2) -> 'a2 + +val printing_pass_independent_params_inv_rect_Type0 : + 'a1 printing_pass_independent_params -> ((String.string -> 'a1) -> (keyword + -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> 'a1 -> (AST.ident -> 'a1) -> + (CostLabel.costlabel -> 'a1) -> (Graphs.label -> 'a1) -> (BackEndOps.opAccs + -> 'a1) -> (BackEndOps.op1 -> 'a1) -> (BackEndOps.op2 -> 'a1) -> (Nat.nat + -> 'a1) -> (Nat.nat -> BitVector.bitVector -> 'a1) -> __ -> 'a2) -> 'a2 + +val printing_pass_independent_params_jmdiscr : + 'a1 printing_pass_independent_params -> 'a1 + printing_pass_independent_params -> __ + +type 'string printing_params = { print_pass_ind : 'string + printing_pass_independent_params; + print_acc_a_reg : (__ -> 'string); + print_acc_b_reg : (__ -> 'string); + print_acc_a_arg : (__ -> 'string); + print_acc_b_arg : (__ -> 'string); + print_dpl_reg : (__ -> 'string); + print_dph_reg : (__ -> 'string); + print_dpl_arg : (__ -> 'string); + print_dph_arg : (__ -> 'string); + print_snd_arg : (__ -> 'string); + print_pair_move : (__ -> 'string); + print_call_args : (__ -> 'string); + print_call_dest : (__ -> 'string); + print_ext_seq : (__ -> 'string) } + +val printing_params_rect_Type4 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 printing_params -> 'a2 + +val printing_params_rect_Type5 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 printing_params -> 'a2 + +val printing_params_rect_Type3 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 printing_params -> 'a2 + +val printing_params_rect_Type2 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 printing_params -> 'a2 + +val printing_params_rect_Type1 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 printing_params -> 'a2 + +val printing_params_rect_Type0 : + Joint.unserialized_params -> ('a1 printing_pass_independent_params -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 printing_params -> 'a2 + +val print_pass_ind : + Joint.unserialized_params -> 'a1 printing_params -> 'a1 + printing_pass_independent_params + +val print_acc_a_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_acc_b_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_acc_a_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_acc_b_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_dpl_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_dph_reg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_dpl_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_dph_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_snd_arg : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_pair_move : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_call_args : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_call_dest : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val print_ext_seq : + Joint.unserialized_params -> 'a1 printing_params -> __ -> 'a1 + +val printing_params_inv_rect_Type4 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val printing_params_inv_rect_Type3 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val printing_params_inv_rect_Type2 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val printing_params_inv_rect_Type1 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val printing_params_inv_rect_Type0 : + Joint.unserialized_params -> 'a1 printing_params -> ('a1 + printing_pass_independent_params -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val printing_params_jmdiscr : + Joint.unserialized_params -> 'a1 printing_params -> 'a1 printing_params -> + __ + +val dpi1__o__print_pass_ind__o__inject : + Joint.unserialized_params -> ('a1 printing_params, 'a2) Types.dPair -> 'a1 + printing_pass_independent_params Types.sig0 + +val eject__o__print_pass_ind__o__inject : + Joint.unserialized_params -> 'a1 printing_params Types.sig0 -> 'a1 + printing_pass_independent_params Types.sig0 + +val print_pass_ind__o__inject : + Joint.unserialized_params -> 'a1 printing_params -> 'a1 + printing_pass_independent_params Types.sig0 + +val dpi1__o__print_pass_ind : + Joint.unserialized_params -> ('a1 printing_params, 'a2) Types.dPair -> 'a1 + printing_pass_independent_params + +val eject__o__print_pass_ind : + Joint.unserialized_params -> 'a1 printing_params Types.sig0 -> 'a1 + printing_pass_independent_params + +type 'string print_serialization_params = { print_succ : (__ -> 'string); + print_code_point : (__ -> + 'string) } + +val print_serialization_params_rect_Type4 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 + +val print_serialization_params_rect_Type5 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 + +val print_serialization_params_rect_Type3 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 + +val print_serialization_params_rect_Type2 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 + +val print_serialization_params_rect_Type1 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 + +val print_serialization_params_rect_Type0 : + Joint.params -> ((__ -> 'a1) -> (__ -> 'a1) -> 'a2) -> 'a1 + print_serialization_params -> 'a2 + +val print_succ : Joint.params -> 'a1 print_serialization_params -> __ -> 'a1 + +val print_code_point : + Joint.params -> 'a1 print_serialization_params -> __ -> 'a1 + +val print_serialization_params_inv_rect_Type4 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val print_serialization_params_inv_rect_Type3 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val print_serialization_params_inv_rect_Type2 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val print_serialization_params_inv_rect_Type1 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val print_serialization_params_inv_rect_Type0 : + Joint.params -> 'a1 print_serialization_params -> ((__ -> 'a1) -> (__ -> + 'a1) -> __ -> 'a2) -> 'a2 + +val print_serialization_params_discr : + Joint.params -> 'a1 print_serialization_params -> 'a1 + print_serialization_params -> __ + +val print_serialization_params_jmdiscr : + Joint.params -> 'a1 print_serialization_params -> 'a1 + print_serialization_params -> __ + +type ('string, 'statementT) code_iteration_params = { cip_print_serialization_params : + 'string + print_serialization_params; + fold_code : (__ -> (__ + -> + 'statementT + -> __ -> + __) -> __ + -> __ -> __ + -> __); + print_statementT : + ('statementT -> + 'string) } + +val code_iteration_params_rect_Type4 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> + 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 + +val code_iteration_params_rect_Type5 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> + 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 + +val code_iteration_params_rect_Type3 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> + 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 + +val code_iteration_params_rect_Type2 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> + 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 + +val code_iteration_params_rect_Type1 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> + 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 + +val code_iteration_params_rect_Type0 : + Joint.params -> AST.ident List.list -> ('a1 print_serialization_params -> + (__ -> (__ -> 'a2 -> __ -> __) -> __ -> __ -> __ -> __) -> ('a2 -> 'a1) -> + 'a3) -> ('a1, 'a2) code_iteration_params -> 'a3 + +val cip_print_serialization_params : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + 'a1 print_serialization_params + +val fold_code0 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + (__ -> 'a2 -> 'a3 -> 'a3) -> __ -> __ -> 'a3 -> 'a3 + +val print_statementT : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + 'a2 -> 'a1 + +val code_iteration_params_inv_rect_Type4 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> __ -> + __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 + +val code_iteration_params_inv_rect_Type3 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> __ -> + __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 + +val code_iteration_params_inv_rect_Type2 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> __ -> + __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 + +val code_iteration_params_inv_rect_Type1 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> __ -> + __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 + +val code_iteration_params_inv_rect_Type0 : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + ('a1 print_serialization_params -> (__ -> (__ -> 'a2 -> __ -> __) -> __ -> + __ -> __ -> __) -> ('a2 -> 'a1) -> __ -> 'a3) -> 'a3 + +val code_iteration_params_jmdiscr : + Joint.params -> AST.ident List.list -> ('a1, 'a2) code_iteration_params -> + ('a1, 'a2) code_iteration_params -> __ + +val pm_choose_with_pref : + 'a1 PositiveMap.positive_map -> Positive.pos Types.option -> + ((Positive.pos, 'a1) Types.prod, 'a1 PositiveMap.positive_map) Types.prod + Types.option + +val visit_graph : + ('a1 -> Positive.pos Types.option) -> (Positive.pos -> 'a1 -> 'a2 -> 'a2) + -> 'a2 -> Positive.pos Types.option -> 'a1 PositiveMap.positive_map -> + Nat.nat -> 'a2 + +val print_list : 'a1 printing_pass_independent_params -> 'a1 List.list -> 'a1 + +val print_joint_seq : + Joint.unserialized_params -> AST.ident List.list -> 'a1 printing_params -> + Joint.joint_seq -> 'a1 + +val print_joint_step : + Joint.unserialized_params -> AST.ident List.list -> 'a1 printing_params -> + Joint.joint_step -> 'a1 + +val print_joint_fin_step : + Joint.unserialized_params -> 'a1 printing_params -> Joint.joint_fin_step -> + 'a1 + +val print_joint_statement : + Joint.params -> AST.ident List.list -> 'a1 printing_params -> 'a1 + print_serialization_params -> Joint.joint_statement -> 'a1 + +val graph_print_serialization_params : + Joint.graph_params -> 'a1 printing_params -> 'a1 print_serialization_params + +val graph_code_iteration_params : + Joint.graph_params -> AST.ident List.list -> 'a1 printing_params -> ('a1, + Joint.joint_statement) code_iteration_params + +val lin_print_serialization_params : + Joint.lin_params -> 'a1 printing_params -> 'a1 print_serialization_params + +val lin_code_iteration_params : + Joint.lin_params -> AST.ident List.list -> 'a1 printing_params -> ('a1, + (Graphs.label Types.option, Joint.joint_statement) Types.prod) + code_iteration_params + +val print_joint_internal_function : + Joint.params -> AST.ident List.list -> ('a2, 'a1) code_iteration_params -> + 'a2 printing_params -> Joint.joint_internal_function -> 'a2 List.list + +val print_joint_function : + Joint.params -> AST.ident List.list -> AST.ident List.list -> ('a2, 'a1) + code_iteration_params -> 'a2 printing_params -> Joint.joint_function -> 'a2 + List.list + +val print_joint_program : + Joint.params -> 'a2 printing_params -> Joint.joint_program -> ('a2, 'a1) + code_iteration_params -> (AST.ident, 'a2 List.list) Types.prod List.list + diff --git a/extracted/joint_semantics.ml b/extracted/joint_semantics.ml new file mode 100644 index 0000000..fa9b622 --- /dev/null +++ b/extracted/joint_semantics.ml @@ -0,0 +1,2603 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open CostLabel + +open Events + +open IOMonad + +open IO + +open BEMem + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open I8051bis + +open ExtraGlobalenvs + +type 'f genv_gen = { ge : 'f AST.fundef Globalenvs.genv_t; + stack_sizes : (AST.ident -> Nat.nat Types.option); + premain : 'f; + pc_from_label : (Pointers.block Types.sig0 -> 'f -> + Graphs.label -> + ByteValues.program_counter Types.option) } + +(** val genv_gen_rect_Type4 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 + -> 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> + 'a2) -> 'a1 genv_gen -> 'a2 **) +let rec genv_gen_rect_Type4 globals h_mk_genv_gen x_24476 = + let { ge = ge0; stack_sizes = stack_sizes0; premain = premain0; + pc_from_label = pc_from_label0 } = x_24476 + in + h_mk_genv_gen ge0 __ stack_sizes0 premain0 pc_from_label0 + +(** val genv_gen_rect_Type5 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 + -> 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> + 'a2) -> 'a1 genv_gen -> 'a2 **) +let rec genv_gen_rect_Type5 globals h_mk_genv_gen x_24478 = + let { ge = ge0; stack_sizes = stack_sizes0; premain = premain0; + pc_from_label = pc_from_label0 } = x_24478 + in + h_mk_genv_gen ge0 __ stack_sizes0 premain0 pc_from_label0 + +(** val genv_gen_rect_Type3 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 + -> 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> + 'a2) -> 'a1 genv_gen -> 'a2 **) +let rec genv_gen_rect_Type3 globals h_mk_genv_gen x_24480 = + let { ge = ge0; stack_sizes = stack_sizes0; premain = premain0; + pc_from_label = pc_from_label0 } = x_24480 + in + h_mk_genv_gen ge0 __ stack_sizes0 premain0 pc_from_label0 + +(** val genv_gen_rect_Type2 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 + -> 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> + 'a2) -> 'a1 genv_gen -> 'a2 **) +let rec genv_gen_rect_Type2 globals h_mk_genv_gen x_24482 = + let { ge = ge0; stack_sizes = stack_sizes0; premain = premain0; + pc_from_label = pc_from_label0 } = x_24482 + in + h_mk_genv_gen ge0 __ stack_sizes0 premain0 pc_from_label0 + +(** val genv_gen_rect_Type1 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 + -> 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> + 'a2) -> 'a1 genv_gen -> 'a2 **) +let rec genv_gen_rect_Type1 globals h_mk_genv_gen x_24484 = + let { ge = ge0; stack_sizes = stack_sizes0; premain = premain0; + pc_from_label = pc_from_label0 } = x_24484 + in + h_mk_genv_gen ge0 __ stack_sizes0 premain0 pc_from_label0 + +(** val genv_gen_rect_Type0 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 + -> 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> + 'a2) -> 'a1 genv_gen -> 'a2 **) +let rec genv_gen_rect_Type0 globals h_mk_genv_gen x_24486 = + let { ge = ge0; stack_sizes = stack_sizes0; premain = premain0; + pc_from_label = pc_from_label0 } = x_24486 + in + h_mk_genv_gen ge0 __ stack_sizes0 premain0 pc_from_label0 + +(** val ge : + AST.ident List.list -> 'a1 genv_gen -> 'a1 AST.fundef Globalenvs.genv_t **) +let rec ge globals xxx = + xxx.ge + +(** val stack_sizes : + AST.ident List.list -> 'a1 genv_gen -> AST.ident -> Nat.nat Types.option **) +let rec stack_sizes globals xxx = + xxx.stack_sizes + +(** val premain : AST.ident List.list -> 'a1 genv_gen -> 'a1 **) +let rec premain globals xxx = + xxx.premain + +(** val pc_from_label : + AST.ident List.list -> 'a1 genv_gen -> Pointers.block Types.sig0 -> 'a1 + -> Graphs.label -> ByteValues.program_counter Types.option **) +let rec pc_from_label globals xxx = + xxx.pc_from_label + +(** val genv_gen_inv_rect_Type4 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t + -> __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 **) +let genv_gen_inv_rect_Type4 x2 hterm h1 = + let hcut = genv_gen_rect_Type4 x2 h1 hterm in hcut __ + +(** val genv_gen_inv_rect_Type3 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t + -> __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 **) +let genv_gen_inv_rect_Type3 x2 hterm h1 = + let hcut = genv_gen_rect_Type3 x2 h1 hterm in hcut __ + +(** val genv_gen_inv_rect_Type2 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t + -> __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 **) +let genv_gen_inv_rect_Type2 x2 hterm h1 = + let hcut = genv_gen_rect_Type2 x2 h1 hterm in hcut __ + +(** val genv_gen_inv_rect_Type1 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t + -> __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 **) +let genv_gen_inv_rect_Type1 x2 hterm h1 = + let hcut = genv_gen_rect_Type1 x2 h1 hterm in hcut __ + +(** val genv_gen_inv_rect_Type0 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t + -> __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 **) +let genv_gen_inv_rect_Type0 x2 hterm h1 = + let hcut = genv_gen_rect_Type0 x2 h1 hterm in hcut __ + +(** val genv_gen_discr : + AST.ident List.list -> 'a1 genv_gen -> 'a1 genv_gen -> __ **) +let genv_gen_discr a2 x y = + Logic.eq_rect_Type2 x + (let { ge = a0; stack_sizes = a20; premain = a3; pc_from_label = a4 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val genv_gen_jmdiscr : + AST.ident List.list -> 'a1 genv_gen -> 'a1 genv_gen -> __ **) +let genv_gen_jmdiscr a2 x y = + Logic.eq_rect_Type2 x + (let { ge = a0; stack_sizes = a20; premain = a3; pc_from_label = a4 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val dpi1__o__ge__o__inject : + AST.ident List.list -> ('a1 genv_gen, 'a2) Types.dPair -> 'a1 AST.fundef + Globalenvs.genv_t Types.sig0 **) +let dpi1__o__ge__o__inject x1 x4 = + x4.Types.dpi1.ge + +(** val eject__o__ge__o__inject : + AST.ident List.list -> 'a1 genv_gen Types.sig0 -> 'a1 AST.fundef + Globalenvs.genv_t Types.sig0 **) +let eject__o__ge__o__inject x1 x4 = + (Types.pi1 x4).ge + +(** val ge__o__inject : + AST.ident List.list -> 'a1 genv_gen -> 'a1 AST.fundef Globalenvs.genv_t + Types.sig0 **) +let ge__o__inject x1 x3 = + x3.ge + +(** val dpi1__o__ge : + AST.ident List.list -> ('a1 genv_gen, 'a2) Types.dPair -> 'a1 AST.fundef + Globalenvs.genv_t **) +let dpi1__o__ge x1 x3 = + x3.Types.dpi1.ge + +(** val eject__o__ge : + AST.ident List.list -> 'a1 genv_gen Types.sig0 -> 'a1 AST.fundef + Globalenvs.genv_t **) +let eject__o__ge x1 x3 = + (Types.pi1 x3).ge + +(** val pre_main_id : AST.ident **) +let pre_main_id = + Positive.One + +(** val fetch_function : + AST.ident List.list -> 'a1 genv_gen -> Pointers.block Types.sig0 -> + (AST.ident, 'a1 AST.fundef) Types.prod Errors.res **) +let fetch_function g ge0 bl = + match Z.eqZb (Pointers.block_id (Types.pi1 bl)) + (Z.zopp (Z.z_of_nat (Nat.S Nat.O))) with + | Bool.True -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = pre_main_id; + Types.snd = (AST.Internal ge0.premain) }) + | Bool.False -> + Errors.opt_to_res (List.Cons ((Errors.MSG ErrorMessages.BadFunction), + List.Nil)) + (Obj.magic + (Monad.m_bind0 (Monad.max_def Option.option) + (Obj.magic (Globalenvs.symbol_for_block ge0.ge (Types.pi1 bl))) + (fun id -> + Monad.m_bind0 (Monad.max_def Option.option) + (Obj.magic (Globalenvs.find_funct_ptr ge0.ge (Types.pi1 bl))) + (fun fd -> + Monad.m_return0 (Monad.max_def Option.option) { Types.fst = id; + Types.snd = fd })))) + +(** val fetch_internal_function : + AST.ident List.list -> 'a1 genv_gen -> Pointers.block Types.sig0 -> + (AST.ident, 'a1) Types.prod Errors.res **) +let fetch_internal_function g ge0 bl = + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (fetch_function g ge0 bl)) (fun id fd -> + match fd with + | AST.Internal ifd -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = id; + Types.snd = ifd } + | AST.External x -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), List.Nil))))) + +(** val code_block_of_block : + Pointers.block -> Pointers.block Types.sig0 Types.option **) +let code_block_of_block bl = + (match Pointers.block_region bl with + | AST.XData -> (fun _ -> Types.None) + | AST.Code -> (fun _ -> Types.Some bl)) __ + +(** val block_of_funct_id : + 'a1 Globalenvs.genv_t -> PreIdentifiers.identifier -> Pointers.block + Types.sig0 Errors.res **) +let block_of_funct_id ge0 id = + Errors.opt_to_res (List.Cons ((Errors.MSG ErrorMessages.BadFunction), + (List.Cons ((Errors.CTX (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Obj.magic + (Monad.m_bind0 (Monad.max_def Option.option) + (Obj.magic (Globalenvs.find_symbol ge0 id)) (fun bl -> + Obj.magic (code_block_of_block bl)))) + +(** val gen_pc_from_label : + AST.ident List.list -> 'a1 genv_gen -> AST.ident -> Graphs.label -> + ByteValues.program_counter Errors.res **) +let gen_pc_from_label g ge0 id lbl = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (block_of_funct_id ge0.ge id)) (fun bl -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (fetch_internal_function g ge0 bl)) (fun ignore f_def -> + Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.LabelNotFound), (List.Cons ((Errors.CTX + (PreIdentifiers.LabelTag, lbl)), List.Nil)))) + (ge0.pc_from_label bl f_def lbl))))) + +type genv = Joint.joint_closed_internal_function genv_gen + +type sem_state_params = { empty_framesT : __; + empty_regsT : (ByteValues.xpointer -> __); + load_sp : (__ -> ByteValues.xpointer Errors.res); + save_sp : (__ -> ByteValues.xpointer -> __) } + +(** val sem_state_params_rect_Type4 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 **) +let rec sem_state_params_rect_Type4 h_mk_sem_state_params x_24507 = + let { empty_framesT = empty_framesT0; empty_regsT = empty_regsT0; load_sp = + load_sp0; save_sp = save_sp0 } = x_24507 + in + h_mk_sem_state_params __ empty_framesT0 __ empty_regsT0 load_sp0 save_sp0 + +(** val sem_state_params_rect_Type5 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 **) +let rec sem_state_params_rect_Type5 h_mk_sem_state_params x_24509 = + let { empty_framesT = empty_framesT0; empty_regsT = empty_regsT0; load_sp = + load_sp0; save_sp = save_sp0 } = x_24509 + in + h_mk_sem_state_params __ empty_framesT0 __ empty_regsT0 load_sp0 save_sp0 + +(** val sem_state_params_rect_Type3 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 **) +let rec sem_state_params_rect_Type3 h_mk_sem_state_params x_24511 = + let { empty_framesT = empty_framesT0; empty_regsT = empty_regsT0; load_sp = + load_sp0; save_sp = save_sp0 } = x_24511 + in + h_mk_sem_state_params __ empty_framesT0 __ empty_regsT0 load_sp0 save_sp0 + +(** val sem_state_params_rect_Type2 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 **) +let rec sem_state_params_rect_Type2 h_mk_sem_state_params x_24513 = + let { empty_framesT = empty_framesT0; empty_regsT = empty_regsT0; load_sp = + load_sp0; save_sp = save_sp0 } = x_24513 + in + h_mk_sem_state_params __ empty_framesT0 __ empty_regsT0 load_sp0 save_sp0 + +(** val sem_state_params_rect_Type1 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 **) +let rec sem_state_params_rect_Type1 h_mk_sem_state_params x_24515 = + let { empty_framesT = empty_framesT0; empty_regsT = empty_regsT0; load_sp = + load_sp0; save_sp = save_sp0 } = x_24515 + in + h_mk_sem_state_params __ empty_framesT0 __ empty_regsT0 load_sp0 save_sp0 + +(** val sem_state_params_rect_Type0 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 **) +let rec sem_state_params_rect_Type0 h_mk_sem_state_params x_24517 = + let { empty_framesT = empty_framesT0; empty_regsT = empty_regsT0; load_sp = + load_sp0; save_sp = save_sp0 } = x_24517 + in + h_mk_sem_state_params __ empty_framesT0 __ empty_regsT0 load_sp0 save_sp0 + +type framesT = __ + +(** val empty_framesT : sem_state_params -> __ **) +let rec empty_framesT xxx = + xxx.empty_framesT + +type regsT = __ + +(** val empty_regsT : sem_state_params -> ByteValues.xpointer -> __ **) +let rec empty_regsT xxx = + xxx.empty_regsT + +(** val load_sp : + sem_state_params -> __ -> ByteValues.xpointer Errors.res **) +let rec load_sp xxx = + xxx.load_sp + +(** val save_sp : sem_state_params -> __ -> ByteValues.xpointer -> __ **) +let rec save_sp xxx = + xxx.save_sp + +(** val sem_state_params_inv_rect_Type4 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) + -> __ -> 'a1) -> 'a1 **) +let sem_state_params_inv_rect_Type4 hterm h1 = + let hcut = sem_state_params_rect_Type4 h1 hterm in hcut __ + +(** val sem_state_params_inv_rect_Type3 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) + -> __ -> 'a1) -> 'a1 **) +let sem_state_params_inv_rect_Type3 hterm h1 = + let hcut = sem_state_params_rect_Type3 h1 hterm in hcut __ + +(** val sem_state_params_inv_rect_Type2 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) + -> __ -> 'a1) -> 'a1 **) +let sem_state_params_inv_rect_Type2 hterm h1 = + let hcut = sem_state_params_rect_Type2 h1 hterm in hcut __ + +(** val sem_state_params_inv_rect_Type1 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) + -> __ -> 'a1) -> 'a1 **) +let sem_state_params_inv_rect_Type1 hterm h1 = + let hcut = sem_state_params_rect_Type1 h1 hterm in hcut __ + +(** val sem_state_params_inv_rect_Type0 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) + -> __ -> 'a1) -> 'a1 **) +let sem_state_params_inv_rect_Type0 hterm h1 = + let hcut = sem_state_params_rect_Type0 h1 hterm in hcut __ + +(** val sem_state_params_jmdiscr : + sem_state_params -> sem_state_params -> __ **) +let sem_state_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { empty_framesT = a1; empty_regsT = a3; load_sp = a4; save_sp = + a5 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +type internal_stack = +| Empty_is +| One_is of ByteValues.beval +| Both_is of ByteValues.beval * ByteValues.beval + +(** val internal_stack_rect_Type4 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 **) +let rec internal_stack_rect_Type4 h_empty_is h_one_is h_both_is = function +| Empty_is -> h_empty_is +| One_is x_24543 -> h_one_is x_24543 +| Both_is (x_24545, x_24544) -> h_both_is x_24545 x_24544 + +(** val internal_stack_rect_Type5 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 **) +let rec internal_stack_rect_Type5 h_empty_is h_one_is h_both_is = function +| Empty_is -> h_empty_is +| One_is x_24550 -> h_one_is x_24550 +| Both_is (x_24552, x_24551) -> h_both_is x_24552 x_24551 + +(** val internal_stack_rect_Type3 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 **) +let rec internal_stack_rect_Type3 h_empty_is h_one_is h_both_is = function +| Empty_is -> h_empty_is +| One_is x_24557 -> h_one_is x_24557 +| Both_is (x_24559, x_24558) -> h_both_is x_24559 x_24558 + +(** val internal_stack_rect_Type2 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 **) +let rec internal_stack_rect_Type2 h_empty_is h_one_is h_both_is = function +| Empty_is -> h_empty_is +| One_is x_24564 -> h_one_is x_24564 +| Both_is (x_24566, x_24565) -> h_both_is x_24566 x_24565 + +(** val internal_stack_rect_Type1 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 **) +let rec internal_stack_rect_Type1 h_empty_is h_one_is h_both_is = function +| Empty_is -> h_empty_is +| One_is x_24571 -> h_one_is x_24571 +| Both_is (x_24573, x_24572) -> h_both_is x_24573 x_24572 + +(** val internal_stack_rect_Type0 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 **) +let rec internal_stack_rect_Type0 h_empty_is h_one_is h_both_is = function +| Empty_is -> h_empty_is +| One_is x_24578 -> h_one_is x_24578 +| Both_is (x_24580, x_24579) -> h_both_is x_24580 x_24579 + +(** val internal_stack_inv_rect_Type4 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 **) +let internal_stack_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = internal_stack_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val internal_stack_inv_rect_Type3 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 **) +let internal_stack_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = internal_stack_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val internal_stack_inv_rect_Type2 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 **) +let internal_stack_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = internal_stack_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val internal_stack_inv_rect_Type1 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 **) +let internal_stack_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = internal_stack_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val internal_stack_inv_rect_Type0 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 **) +let internal_stack_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = internal_stack_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val internal_stack_discr : internal_stack -> internal_stack -> __ **) +let internal_stack_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Empty_is -> Obj.magic (fun _ dH -> dH) + | One_is a0 -> Obj.magic (fun _ dH -> dH __) + | Both_is (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val internal_stack_jmdiscr : internal_stack -> internal_stack -> __ **) +let internal_stack_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Empty_is -> Obj.magic (fun _ dH -> dH) + | One_is a0 -> Obj.magic (fun _ dH -> dH __) + | Both_is (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val is_push : + internal_stack -> ByteValues.beval -> internal_stack Errors.res **) +let is_push is bv = + match is with + | Empty_is -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) (One_is bv)) + | One_is bv' -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) (Both_is (bv', bv))) + | Both_is (x, x0) -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.InternalStackFull), + List.Nil)) + +(** val is_pop : + internal_stack -> (ByteValues.beval, internal_stack) Types.prod + Errors.res **) +let is_pop = function +| Empty_is -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.InternalStackEmpty), + List.Nil)) +| One_is bv' -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = bv'; + Types.snd = Empty_is }) +| Both_is (bv, bv') -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = bv'; + Types.snd = (One_is bv) }) + +type state = { st_frms : __ Types.option; istack : internal_stack; + carry : ByteValues.bebit; regs : __; m : BEMem.bemem; + stack_usage : Nat.nat } + +(** val state_rect_Type4 : + sem_state_params -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type4 semp h_mk_state x_24628 = + let { st_frms = st_frms0; istack = istack0; carry = carry0; regs = regs0; + m = m0; stack_usage = stack_usage0 } = x_24628 + in + h_mk_state st_frms0 istack0 carry0 regs0 m0 stack_usage0 + +(** val state_rect_Type5 : + sem_state_params -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type5 semp h_mk_state x_24630 = + let { st_frms = st_frms0; istack = istack0; carry = carry0; regs = regs0; + m = m0; stack_usage = stack_usage0 } = x_24630 + in + h_mk_state st_frms0 istack0 carry0 regs0 m0 stack_usage0 + +(** val state_rect_Type3 : + sem_state_params -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type3 semp h_mk_state x_24632 = + let { st_frms = st_frms0; istack = istack0; carry = carry0; regs = regs0; + m = m0; stack_usage = stack_usage0 } = x_24632 + in + h_mk_state st_frms0 istack0 carry0 regs0 m0 stack_usage0 + +(** val state_rect_Type2 : + sem_state_params -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type2 semp h_mk_state x_24634 = + let { st_frms = st_frms0; istack = istack0; carry = carry0; regs = regs0; + m = m0; stack_usage = stack_usage0 } = x_24634 + in + h_mk_state st_frms0 istack0 carry0 regs0 m0 stack_usage0 + +(** val state_rect_Type1 : + sem_state_params -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type1 semp h_mk_state x_24636 = + let { st_frms = st_frms0; istack = istack0; carry = carry0; regs = regs0; + m = m0; stack_usage = stack_usage0 } = x_24636 + in + h_mk_state st_frms0 istack0 carry0 regs0 m0 stack_usage0 + +(** val state_rect_Type0 : + sem_state_params -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type0 semp h_mk_state x_24638 = + let { st_frms = st_frms0; istack = istack0; carry = carry0; regs = regs0; + m = m0; stack_usage = stack_usage0 } = x_24638 + in + h_mk_state st_frms0 istack0 carry0 regs0 m0 stack_usage0 + +(** val st_frms : sem_state_params -> state -> __ Types.option **) +let rec st_frms semp xxx = + xxx.st_frms + +(** val istack : sem_state_params -> state -> internal_stack **) +let rec istack semp xxx = + xxx.istack + +(** val carry : sem_state_params -> state -> ByteValues.bebit **) +let rec carry semp xxx = + xxx.carry + +(** val regs : sem_state_params -> state -> __ **) +let rec regs semp xxx = + xxx.regs + +(** val m : sem_state_params -> state -> BEMem.bemem **) +let rec m semp xxx = + xxx.m + +(** val stack_usage : sem_state_params -> state -> Nat.nat **) +let rec stack_usage semp xxx = + xxx.stack_usage + +(** val state_inv_rect_Type4 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type4 x1 hterm h1 = + let hcut = state_rect_Type4 x1 h1 hterm in hcut __ + +(** val state_inv_rect_Type3 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type3 x1 hterm h1 = + let hcut = state_rect_Type3 x1 h1 hterm in hcut __ + +(** val state_inv_rect_Type2 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type2 x1 hterm h1 = + let hcut = state_rect_Type2 x1 h1 hterm in hcut __ + +(** val state_inv_rect_Type1 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type1 x1 hterm h1 = + let hcut = state_rect_Type1 x1 h1 hterm in hcut __ + +(** val state_inv_rect_Type0 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type0 x1 hterm h1 = + let hcut = state_rect_Type0 x1 h1 hterm in hcut __ + +(** val state_jmdiscr : sem_state_params -> state -> state -> __ **) +let state_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { st_frms = a0; istack = a10; carry = a2; regs = a3; m = a4; + stack_usage = a5 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val sp : sem_state_params -> state -> ByteValues.xpointer Errors.res **) +let sp p st = + p.load_sp st.regs + +type state_pc = { st_no_pc : state; pc : ByteValues.program_counter; + last_pop : ByteValues.program_counter } + +(** val state_pc_rect_Type4 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 **) +let rec state_pc_rect_Type4 semp h_mk_state_pc x_24654 = + let { st_no_pc = st_no_pc0; pc = pc0; last_pop = last_pop0 } = x_24654 in + h_mk_state_pc st_no_pc0 pc0 last_pop0 + +(** val state_pc_rect_Type5 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 **) +let rec state_pc_rect_Type5 semp h_mk_state_pc x_24656 = + let { st_no_pc = st_no_pc0; pc = pc0; last_pop = last_pop0 } = x_24656 in + h_mk_state_pc st_no_pc0 pc0 last_pop0 + +(** val state_pc_rect_Type3 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 **) +let rec state_pc_rect_Type3 semp h_mk_state_pc x_24658 = + let { st_no_pc = st_no_pc0; pc = pc0; last_pop = last_pop0 } = x_24658 in + h_mk_state_pc st_no_pc0 pc0 last_pop0 + +(** val state_pc_rect_Type2 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 **) +let rec state_pc_rect_Type2 semp h_mk_state_pc x_24660 = + let { st_no_pc = st_no_pc0; pc = pc0; last_pop = last_pop0 } = x_24660 in + h_mk_state_pc st_no_pc0 pc0 last_pop0 + +(** val state_pc_rect_Type1 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 **) +let rec state_pc_rect_Type1 semp h_mk_state_pc x_24662 = + let { st_no_pc = st_no_pc0; pc = pc0; last_pop = last_pop0 } = x_24662 in + h_mk_state_pc st_no_pc0 pc0 last_pop0 + +(** val state_pc_rect_Type0 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 **) +let rec state_pc_rect_Type0 semp h_mk_state_pc x_24664 = + let { st_no_pc = st_no_pc0; pc = pc0; last_pop = last_pop0 } = x_24664 in + h_mk_state_pc st_no_pc0 pc0 last_pop0 + +(** val st_no_pc : sem_state_params -> state_pc -> state **) +let rec st_no_pc semp xxx = + xxx.st_no_pc + +(** val pc : sem_state_params -> state_pc -> ByteValues.program_counter **) +let rec pc semp xxx = + xxx.pc + +(** val last_pop : + sem_state_params -> state_pc -> ByteValues.program_counter **) +let rec last_pop semp xxx = + xxx.last_pop + +(** val state_pc_inv_rect_Type4 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 **) +let state_pc_inv_rect_Type4 x1 hterm h1 = + let hcut = state_pc_rect_Type4 x1 h1 hterm in hcut __ + +(** val state_pc_inv_rect_Type3 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 **) +let state_pc_inv_rect_Type3 x1 hterm h1 = + let hcut = state_pc_rect_Type3 x1 h1 hterm in hcut __ + +(** val state_pc_inv_rect_Type2 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 **) +let state_pc_inv_rect_Type2 x1 hterm h1 = + let hcut = state_pc_rect_Type2 x1 h1 hterm in hcut __ + +(** val state_pc_inv_rect_Type1 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 **) +let state_pc_inv_rect_Type1 x1 hterm h1 = + let hcut = state_pc_rect_Type1 x1 h1 hterm in hcut __ + +(** val state_pc_inv_rect_Type0 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 **) +let state_pc_inv_rect_Type0 x1 hterm h1 = + let hcut = state_pc_rect_Type0 x1 h1 hterm in hcut __ + +(** val state_pc_discr : sem_state_params -> state_pc -> state_pc -> __ **) +let state_pc_discr a1 x y = + Logic.eq_rect_Type2 x + (let { st_no_pc = a0; pc = a10; last_pop = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val state_pc_jmdiscr : sem_state_params -> state_pc -> state_pc -> __ **) +let state_pc_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { st_no_pc = a0; pc = a10; last_pop = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val dpi1__o__st_no_pc__o__inject : + sem_state_params -> (state_pc, 'a1) Types.dPair -> state Types.sig0 **) +let dpi1__o__st_no_pc__o__inject x0 x3 = + x3.Types.dpi1.st_no_pc + +(** val eject__o__st_no_pc__o__inject : + sem_state_params -> state_pc Types.sig0 -> state Types.sig0 **) +let eject__o__st_no_pc__o__inject x0 x3 = + (Types.pi1 x3).st_no_pc + +(** val st_no_pc__o__inject : + sem_state_params -> state_pc -> state Types.sig0 **) +let st_no_pc__o__inject x0 x2 = + x2.st_no_pc + +(** val dpi1__o__st_no_pc : + sem_state_params -> (state_pc, 'a1) Types.dPair -> state **) +let dpi1__o__st_no_pc x0 x2 = + x2.Types.dpi1.st_no_pc + +(** val eject__o__st_no_pc : + sem_state_params -> state_pc Types.sig0 -> state **) +let eject__o__st_no_pc x0 x2 = + (Types.pi1 x2).st_no_pc + +(** val init_pc : ByteValues.program_counter **) +let init_pc = + { ByteValues.pc_block = (Z.zopp (Z.z_of_nat (Nat.S Nat.O))); + ByteValues.pc_offset = Positive.One } + +(** val null_pc : Positive.pos -> ByteValues.program_counter **) +let null_pc pos = + { ByteValues.pc_block = Pointers.dummy_block_code; ByteValues.pc_offset = + pos } + +(** val set_m : sem_state_params -> BEMem.bemem -> state -> state **) +let set_m p m0 st = + { st_frms = st.st_frms; istack = st.istack; carry = st.carry; regs = + st.regs; m = m0; stack_usage = st.stack_usage } + +(** val set_regs : sem_state_params -> __ -> state -> state **) +let set_regs p regs0 st = + { st_frms = st.st_frms; istack = st.istack; carry = st.carry; regs = regs0; + m = st.m; stack_usage = st.stack_usage } + +(** val set_sp : + sem_state_params -> ByteValues.xpointer -> state -> state **) +let set_sp p sp0 st = + let regs' = p.save_sp st.regs sp0 in + { st_frms = st.st_frms; istack = st.istack; carry = st.carry; regs = regs'; + m = st.m; stack_usage = st.stack_usage } + +(** val set_carry : + sem_state_params -> ByteValues.bebit -> state -> state **) +let set_carry p carry0 st = + { st_frms = st.st_frms; istack = st.istack; carry = carry0; regs = st.regs; + m = st.m; stack_usage = st.stack_usage } + +(** val set_istack : sem_state_params -> internal_stack -> state -> state **) +let set_istack p is st = + { st_frms = st.st_frms; istack = is; carry = st.carry; regs = st.regs; m = + st.m; stack_usage = st.stack_usage } + +(** val set_pc : + sem_state_params -> ByteValues.program_counter -> state_pc -> state_pc **) +let set_pc p pc0 st = + { st_no_pc = st.st_no_pc; pc = pc0; last_pop = st.last_pop } + +(** val set_no_pc : sem_state_params -> state -> state_pc -> state_pc **) +let set_no_pc p s st = + { st_no_pc = s; pc = st.pc; last_pop = st.last_pop } + +(** val set_last_pop : + sem_state_params -> state -> ByteValues.program_counter -> state_pc **) +let set_last_pop p st pc0 = + { st_no_pc = st; pc = pc0; last_pop = pc0 } + +(** val set_frms : sem_state_params -> __ -> state -> state **) +let set_frms p frms st = + { st_frms = (Types.Some frms); istack = st.istack; carry = st.carry; regs = + st.regs; m = st.m; stack_usage = st.stack_usage } + +type call_kind = +| PTR +| ID + +(** val call_kind_rect_Type4 : 'a1 -> 'a1 -> call_kind -> 'a1 **) +let rec call_kind_rect_Type4 h_PTR h_ID = function +| PTR -> h_PTR +| ID -> h_ID + +(** val call_kind_rect_Type5 : 'a1 -> 'a1 -> call_kind -> 'a1 **) +let rec call_kind_rect_Type5 h_PTR h_ID = function +| PTR -> h_PTR +| ID -> h_ID + +(** val call_kind_rect_Type3 : 'a1 -> 'a1 -> call_kind -> 'a1 **) +let rec call_kind_rect_Type3 h_PTR h_ID = function +| PTR -> h_PTR +| ID -> h_ID + +(** val call_kind_rect_Type2 : 'a1 -> 'a1 -> call_kind -> 'a1 **) +let rec call_kind_rect_Type2 h_PTR h_ID = function +| PTR -> h_PTR +| ID -> h_ID + +(** val call_kind_rect_Type1 : 'a1 -> 'a1 -> call_kind -> 'a1 **) +let rec call_kind_rect_Type1 h_PTR h_ID = function +| PTR -> h_PTR +| ID -> h_ID + +(** val call_kind_rect_Type0 : 'a1 -> 'a1 -> call_kind -> 'a1 **) +let rec call_kind_rect_Type0 h_PTR h_ID = function +| PTR -> h_PTR +| ID -> h_ID + +(** val call_kind_inv_rect_Type4 : + call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let call_kind_inv_rect_Type4 hterm h1 h2 = + let hcut = call_kind_rect_Type4 h1 h2 hterm in hcut __ + +(** val call_kind_inv_rect_Type3 : + call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let call_kind_inv_rect_Type3 hterm h1 h2 = + let hcut = call_kind_rect_Type3 h1 h2 hterm in hcut __ + +(** val call_kind_inv_rect_Type2 : + call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let call_kind_inv_rect_Type2 hterm h1 h2 = + let hcut = call_kind_rect_Type2 h1 h2 hterm in hcut __ + +(** val call_kind_inv_rect_Type1 : + call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let call_kind_inv_rect_Type1 hterm h1 h2 = + let hcut = call_kind_rect_Type1 h1 h2 hterm in hcut __ + +(** val call_kind_inv_rect_Type0 : + call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let call_kind_inv_rect_Type0 hterm h1 h2 = + let hcut = call_kind_rect_Type0 h1 h2 hterm in hcut __ + +(** val call_kind_discr : call_kind -> call_kind -> __ **) +let call_kind_discr x y = + Logic.eq_rect_Type2 x + (match x with + | PTR -> Obj.magic (fun _ dH -> dH) + | ID -> Obj.magic (fun _ dH -> dH)) y + +(** val call_kind_jmdiscr : call_kind -> call_kind -> __ **) +let call_kind_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | PTR -> Obj.magic (fun _ dH -> dH) + | ID -> Obj.magic (fun _ dH -> dH)) y + +(** val kind_of_call : + Joint.unserialized_params -> (AST.ident, (__, __) Types.prod) Types.sum + -> call_kind **) +let kind_of_call p = function +| Types.Inl x -> ID +| Types.Inr x -> PTR + +type 'f sem_unserialized_params = { st_pars : sem_state_params; + acca_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + acca_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + acca_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + accb_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + accb_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + accb_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dpl_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + dpl_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dpl_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dph_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + dph_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dph_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + snd_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + pair_reg_move_ : (__ -> __ -> __ + Errors.res); + save_frame : (call_kind -> __ -> state_pc + -> state Errors.res); + setup_call : (Nat.nat -> __ -> __ -> + state -> state Errors.res); + fetch_external_args : (AST.external_function + -> state -> __ -> + Values.val0 + List.list + Errors.res); + set_result : (Values.val0 List.list -> __ + -> state -> state + Errors.res); + call_args_for_main : __; + call_dest_for_main : __; + read_result : (AST.ident List.list -> 'f + AST.fundef + Globalenvs.genv_t -> __ -> + state -> ByteValues.beval + List.list Errors.res); + eval_ext_seq : (AST.ident List.list -> 'f + genv_gen -> __ -> + AST.ident -> state -> + state Errors.res); + pop_frame : (AST.ident List.list -> 'f + genv_gen -> AST.ident -> __ + -> state -> (state, + ByteValues.program_counter) + Types.prod Errors.res) } + +(** val sem_unserialized_params_rect_Type4 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> + __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> + 'a2) -> 'a1 sem_unserialized_params -> 'a2 **) +let rec sem_unserialized_params_rect_Type4 uns_pars h_mk_sem_unserialized_params x_24719 = + let { st_pars = st_pars0; acca_store_ = acca_store_0; acca_retrieve_ = + acca_retrieve_0; acca_arg_retrieve_ = acca_arg_retrieve_0; accb_store_ = + accb_store_0; accb_retrieve_ = accb_retrieve_0; accb_arg_retrieve_ = + accb_arg_retrieve_0; dpl_store_ = dpl_store_0; dpl_retrieve_ = + dpl_retrieve_0; dpl_arg_retrieve_ = dpl_arg_retrieve_0; dph_store_ = + dph_store_0; dph_retrieve_ = dph_retrieve_0; dph_arg_retrieve_ = + dph_arg_retrieve_0; snd_arg_retrieve_ = snd_arg_retrieve_0; + pair_reg_move_ = pair_reg_move_0; save_frame = save_frame0; setup_call = + setup_call0; fetch_external_args = fetch_external_args0; set_result = + set_result0; call_args_for_main = call_args_for_main0; + call_dest_for_main = call_dest_for_main0; read_result = read_result0; + eval_ext_seq = eval_ext_seq0; pop_frame = pop_frame0 } = x_24719 + in + h_mk_sem_unserialized_params st_pars0 acca_store_0 acca_retrieve_0 + acca_arg_retrieve_0 accb_store_0 accb_retrieve_0 accb_arg_retrieve_0 + dpl_store_0 dpl_retrieve_0 dpl_arg_retrieve_0 dph_store_0 dph_retrieve_0 + dph_arg_retrieve_0 snd_arg_retrieve_0 pair_reg_move_0 save_frame0 + setup_call0 fetch_external_args0 set_result0 call_args_for_main0 + call_dest_for_main0 read_result0 eval_ext_seq0 pop_frame0 + +(** val sem_unserialized_params_rect_Type5 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> + __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> + 'a2) -> 'a1 sem_unserialized_params -> 'a2 **) +let rec sem_unserialized_params_rect_Type5 uns_pars h_mk_sem_unserialized_params x_24721 = + let { st_pars = st_pars0; acca_store_ = acca_store_0; acca_retrieve_ = + acca_retrieve_0; acca_arg_retrieve_ = acca_arg_retrieve_0; accb_store_ = + accb_store_0; accb_retrieve_ = accb_retrieve_0; accb_arg_retrieve_ = + accb_arg_retrieve_0; dpl_store_ = dpl_store_0; dpl_retrieve_ = + dpl_retrieve_0; dpl_arg_retrieve_ = dpl_arg_retrieve_0; dph_store_ = + dph_store_0; dph_retrieve_ = dph_retrieve_0; dph_arg_retrieve_ = + dph_arg_retrieve_0; snd_arg_retrieve_ = snd_arg_retrieve_0; + pair_reg_move_ = pair_reg_move_0; save_frame = save_frame0; setup_call = + setup_call0; fetch_external_args = fetch_external_args0; set_result = + set_result0; call_args_for_main = call_args_for_main0; + call_dest_for_main = call_dest_for_main0; read_result = read_result0; + eval_ext_seq = eval_ext_seq0; pop_frame = pop_frame0 } = x_24721 + in + h_mk_sem_unserialized_params st_pars0 acca_store_0 acca_retrieve_0 + acca_arg_retrieve_0 accb_store_0 accb_retrieve_0 accb_arg_retrieve_0 + dpl_store_0 dpl_retrieve_0 dpl_arg_retrieve_0 dph_store_0 dph_retrieve_0 + dph_arg_retrieve_0 snd_arg_retrieve_0 pair_reg_move_0 save_frame0 + setup_call0 fetch_external_args0 set_result0 call_args_for_main0 + call_dest_for_main0 read_result0 eval_ext_seq0 pop_frame0 + +(** val sem_unserialized_params_rect_Type3 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> + __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> + 'a2) -> 'a1 sem_unserialized_params -> 'a2 **) +let rec sem_unserialized_params_rect_Type3 uns_pars h_mk_sem_unserialized_params x_24723 = + let { st_pars = st_pars0; acca_store_ = acca_store_0; acca_retrieve_ = + acca_retrieve_0; acca_arg_retrieve_ = acca_arg_retrieve_0; accb_store_ = + accb_store_0; accb_retrieve_ = accb_retrieve_0; accb_arg_retrieve_ = + accb_arg_retrieve_0; dpl_store_ = dpl_store_0; dpl_retrieve_ = + dpl_retrieve_0; dpl_arg_retrieve_ = dpl_arg_retrieve_0; dph_store_ = + dph_store_0; dph_retrieve_ = dph_retrieve_0; dph_arg_retrieve_ = + dph_arg_retrieve_0; snd_arg_retrieve_ = snd_arg_retrieve_0; + pair_reg_move_ = pair_reg_move_0; save_frame = save_frame0; setup_call = + setup_call0; fetch_external_args = fetch_external_args0; set_result = + set_result0; call_args_for_main = call_args_for_main0; + call_dest_for_main = call_dest_for_main0; read_result = read_result0; + eval_ext_seq = eval_ext_seq0; pop_frame = pop_frame0 } = x_24723 + in + h_mk_sem_unserialized_params st_pars0 acca_store_0 acca_retrieve_0 + acca_arg_retrieve_0 accb_store_0 accb_retrieve_0 accb_arg_retrieve_0 + dpl_store_0 dpl_retrieve_0 dpl_arg_retrieve_0 dph_store_0 dph_retrieve_0 + dph_arg_retrieve_0 snd_arg_retrieve_0 pair_reg_move_0 save_frame0 + setup_call0 fetch_external_args0 set_result0 call_args_for_main0 + call_dest_for_main0 read_result0 eval_ext_seq0 pop_frame0 + +(** val sem_unserialized_params_rect_Type2 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> + __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> + 'a2) -> 'a1 sem_unserialized_params -> 'a2 **) +let rec sem_unserialized_params_rect_Type2 uns_pars h_mk_sem_unserialized_params x_24725 = + let { st_pars = st_pars0; acca_store_ = acca_store_0; acca_retrieve_ = + acca_retrieve_0; acca_arg_retrieve_ = acca_arg_retrieve_0; accb_store_ = + accb_store_0; accb_retrieve_ = accb_retrieve_0; accb_arg_retrieve_ = + accb_arg_retrieve_0; dpl_store_ = dpl_store_0; dpl_retrieve_ = + dpl_retrieve_0; dpl_arg_retrieve_ = dpl_arg_retrieve_0; dph_store_ = + dph_store_0; dph_retrieve_ = dph_retrieve_0; dph_arg_retrieve_ = + dph_arg_retrieve_0; snd_arg_retrieve_ = snd_arg_retrieve_0; + pair_reg_move_ = pair_reg_move_0; save_frame = save_frame0; setup_call = + setup_call0; fetch_external_args = fetch_external_args0; set_result = + set_result0; call_args_for_main = call_args_for_main0; + call_dest_for_main = call_dest_for_main0; read_result = read_result0; + eval_ext_seq = eval_ext_seq0; pop_frame = pop_frame0 } = x_24725 + in + h_mk_sem_unserialized_params st_pars0 acca_store_0 acca_retrieve_0 + acca_arg_retrieve_0 accb_store_0 accb_retrieve_0 accb_arg_retrieve_0 + dpl_store_0 dpl_retrieve_0 dpl_arg_retrieve_0 dph_store_0 dph_retrieve_0 + dph_arg_retrieve_0 snd_arg_retrieve_0 pair_reg_move_0 save_frame0 + setup_call0 fetch_external_args0 set_result0 call_args_for_main0 + call_dest_for_main0 read_result0 eval_ext_seq0 pop_frame0 + +(** val sem_unserialized_params_rect_Type1 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> + __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> + 'a2) -> 'a1 sem_unserialized_params -> 'a2 **) +let rec sem_unserialized_params_rect_Type1 uns_pars h_mk_sem_unserialized_params x_24727 = + let { st_pars = st_pars0; acca_store_ = acca_store_0; acca_retrieve_ = + acca_retrieve_0; acca_arg_retrieve_ = acca_arg_retrieve_0; accb_store_ = + accb_store_0; accb_retrieve_ = accb_retrieve_0; accb_arg_retrieve_ = + accb_arg_retrieve_0; dpl_store_ = dpl_store_0; dpl_retrieve_ = + dpl_retrieve_0; dpl_arg_retrieve_ = dpl_arg_retrieve_0; dph_store_ = + dph_store_0; dph_retrieve_ = dph_retrieve_0; dph_arg_retrieve_ = + dph_arg_retrieve_0; snd_arg_retrieve_ = snd_arg_retrieve_0; + pair_reg_move_ = pair_reg_move_0; save_frame = save_frame0; setup_call = + setup_call0; fetch_external_args = fetch_external_args0; set_result = + set_result0; call_args_for_main = call_args_for_main0; + call_dest_for_main = call_dest_for_main0; read_result = read_result0; + eval_ext_seq = eval_ext_seq0; pop_frame = pop_frame0 } = x_24727 + in + h_mk_sem_unserialized_params st_pars0 acca_store_0 acca_retrieve_0 + acca_arg_retrieve_0 accb_store_0 accb_retrieve_0 accb_arg_retrieve_0 + dpl_store_0 dpl_retrieve_0 dpl_arg_retrieve_0 dph_store_0 dph_retrieve_0 + dph_arg_retrieve_0 snd_arg_retrieve_0 pair_reg_move_0 save_frame0 + setup_call0 fetch_external_args0 set_result0 call_args_for_main0 + call_dest_for_main0 read_result0 eval_ext_seq0 pop_frame0 + +(** val sem_unserialized_params_rect_Type0 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> + __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> + 'a2) -> 'a1 sem_unserialized_params -> 'a2 **) +let rec sem_unserialized_params_rect_Type0 uns_pars h_mk_sem_unserialized_params x_24729 = + let { st_pars = st_pars0; acca_store_ = acca_store_0; acca_retrieve_ = + acca_retrieve_0; acca_arg_retrieve_ = acca_arg_retrieve_0; accb_store_ = + accb_store_0; accb_retrieve_ = accb_retrieve_0; accb_arg_retrieve_ = + accb_arg_retrieve_0; dpl_store_ = dpl_store_0; dpl_retrieve_ = + dpl_retrieve_0; dpl_arg_retrieve_ = dpl_arg_retrieve_0; dph_store_ = + dph_store_0; dph_retrieve_ = dph_retrieve_0; dph_arg_retrieve_ = + dph_arg_retrieve_0; snd_arg_retrieve_ = snd_arg_retrieve_0; + pair_reg_move_ = pair_reg_move_0; save_frame = save_frame0; setup_call = + setup_call0; fetch_external_args = fetch_external_args0; set_result = + set_result0; call_args_for_main = call_args_for_main0; + call_dest_for_main = call_dest_for_main0; read_result = read_result0; + eval_ext_seq = eval_ext_seq0; pop_frame = pop_frame0 } = x_24729 + in + h_mk_sem_unserialized_params st_pars0 acca_store_0 acca_retrieve_0 + acca_arg_retrieve_0 accb_store_0 accb_retrieve_0 accb_arg_retrieve_0 + dpl_store_0 dpl_retrieve_0 dpl_arg_retrieve_0 dph_store_0 dph_retrieve_0 + dph_arg_retrieve_0 snd_arg_retrieve_0 pair_reg_move_0 save_frame0 + setup_call0 fetch_external_args0 set_result0 call_args_for_main0 + call_dest_for_main0 read_result0 eval_ext_seq0 pop_frame0 + +(** val st_pars : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + sem_state_params **) +let rec st_pars uns_pars xxx = + xxx.st_pars + +(** val acca_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res **) +let rec acca_store_ uns_pars xxx = + xxx.acca_store_ + +(** val acca_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec acca_retrieve_ uns_pars xxx = + xxx.acca_retrieve_ + +(** val acca_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec acca_arg_retrieve_ uns_pars xxx = + xxx.acca_arg_retrieve_ + +(** val accb_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res **) +let rec accb_store_ uns_pars xxx = + xxx.accb_store_ + +(** val accb_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec accb_retrieve_ uns_pars xxx = + xxx.accb_retrieve_ + +(** val accb_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec accb_arg_retrieve_ uns_pars xxx = + xxx.accb_arg_retrieve_ + +(** val dpl_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res **) +let rec dpl_store_ uns_pars xxx = + xxx.dpl_store_ + +(** val dpl_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec dpl_retrieve_ uns_pars xxx = + xxx.dpl_retrieve_ + +(** val dpl_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec dpl_arg_retrieve_ uns_pars xxx = + xxx.dpl_arg_retrieve_ + +(** val dph_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res **) +let rec dph_store_ uns_pars xxx = + xxx.dph_store_ + +(** val dph_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec dph_retrieve_ uns_pars xxx = + xxx.dph_retrieve_ + +(** val dph_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec dph_arg_retrieve_ uns_pars xxx = + xxx.dph_arg_retrieve_ + +(** val snd_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res **) +let rec snd_arg_retrieve_ uns_pars xxx = + xxx.snd_arg_retrieve_ + +(** val pair_reg_move_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + __ Errors.res **) +let rec pair_reg_move_ uns_pars xxx = + xxx.pair_reg_move_ + +(** val save_frame : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> call_kind -> + __ -> state_pc -> state Errors.res **) +let rec save_frame uns_pars xxx = + xxx.save_frame + +(** val setup_call : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> Nat.nat -> __ + -> __ -> state -> state Errors.res **) +let rec setup_call uns_pars xxx = + xxx.setup_call + +(** val fetch_external_args : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + AST.external_function -> state -> __ -> Values.val0 List.list Errors.res **) +let rec fetch_external_args uns_pars xxx = + xxx.fetch_external_args + +(** val set_result : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> Values.val0 + List.list -> __ -> state -> state Errors.res **) +let rec set_result uns_pars xxx = + xxx.set_result + +(** val call_args_for_main : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ **) +let rec call_args_for_main uns_pars xxx = + xxx.call_args_for_main + +(** val call_dest_for_main : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ **) +let rec call_dest_for_main uns_pars xxx = + xxx.call_dest_for_main + +(** val read_result : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> AST.ident + List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state -> + ByteValues.beval List.list Errors.res **) +let rec read_result uns_pars xxx = + xxx.read_result + +(** val eval_ext_seq : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state Errors.res **) +let rec eval_ext_seq uns_pars xxx = + xxx.eval_ext_seq + +(** val pop_frame : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res **) +let rec pop_frame uns_pars xxx = + xxx.pop_frame + +(** val sem_unserialized_params_inv_rect_Type4 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> __ + -> 'a2) -> 'a2 **) +let sem_unserialized_params_inv_rect_Type4 x1 hterm h1 = + let hcut = sem_unserialized_params_rect_Type4 x1 h1 hterm in hcut __ + +(** val sem_unserialized_params_inv_rect_Type3 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> __ + -> 'a2) -> 'a2 **) +let sem_unserialized_params_inv_rect_Type3 x1 hterm h1 = + let hcut = sem_unserialized_params_rect_Type3 x1 h1 hterm in hcut __ + +(** val sem_unserialized_params_inv_rect_Type2 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> __ + -> 'a2) -> 'a2 **) +let sem_unserialized_params_inv_rect_Type2 x1 hterm h1 = + let hcut = sem_unserialized_params_rect_Type2 x1 h1 hterm in hcut __ + +(** val sem_unserialized_params_inv_rect_Type1 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> __ + -> 'a2) -> 'a2 **) +let sem_unserialized_params_inv_rect_Type1 x1 hterm h1 = + let hcut = sem_unserialized_params_rect_Type1 x1 h1 hterm in hcut __ + +(** val sem_unserialized_params_inv_rect_Type0 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> + (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list + Errors.res) -> (Values.val0 List.list -> __ -> state -> state Errors.res) + -> __ -> __ -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t + -> __ -> state -> ByteValues.beval List.list Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state + Errors.res) -> (AST.ident List.list -> 'a1 genv_gen -> AST.ident -> __ -> + state -> (state, ByteValues.program_counter) Types.prod Errors.res) -> __ + -> 'a2) -> 'a2 **) +let sem_unserialized_params_inv_rect_Type0 x1 hterm h1 = + let hcut = sem_unserialized_params_rect_Type0 x1 h1 hterm in hcut __ + +(** val sem_unserialized_params_jmdiscr : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> 'a1 + sem_unserialized_params -> __ **) +let sem_unserialized_params_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { st_pars = a0; acca_store_ = a10; acca_retrieve_ = a20; + acca_arg_retrieve_ = a3; accb_store_ = a4; accb_retrieve_ = a5; + accb_arg_retrieve_ = a6; dpl_store_ = a7; dpl_retrieve_ = a8; + dpl_arg_retrieve_ = a9; dph_store_ = a100; dph_retrieve_ = a11; + dph_arg_retrieve_ = a12; snd_arg_retrieve_ = a13; pair_reg_move_ = + a14; save_frame = a15; setup_call = a16; fetch_external_args = a17; + set_result = a18; call_args_for_main = a19; call_dest_for_main = a200; + read_result = a21; eval_ext_seq = a22; pop_frame = a23 } = x + in + Obj.magic (fun _ dH -> + dH __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ + __)) y + +(** val helper_def_retrieve : + (Joint.unserialized_params -> __ -> __ sem_unserialized_params -> __ -> + 'a1 -> ByteValues.beval Errors.res) -> Joint.unserialized_params -> 'a2 + sem_unserialized_params -> state -> 'a1 -> ByteValues.beval Errors.res **) +let helper_def_retrieve f up p st = + Obj.magic f up __ p st.regs + +(** val helper_def_store : + (Joint.unserialized_params -> __ -> __ sem_unserialized_params -> 'a1 -> + ByteValues.beval -> __ -> __ Errors.res) -> Joint.unserialized_params -> + 'a2 sem_unserialized_params -> 'a1 -> ByteValues.beval -> state -> state + Errors.res **) +let helper_def_store f up p x v st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic f up __ p x v st.regs) (fun r -> + Monad.m_return0 (Monad.max_def Errors.res0) (set_regs p.st_pars r st))) + +(** val acca_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let acca_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> acca_retrieve_ x1) up p x x0 + +(** val acca_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res **) +let acca_store up p x x0 x1 = + helper_def_store (fun x2 _ -> acca_store_ x2) up p x x0 x1 + +(** val acca_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let acca_arg_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> acca_arg_retrieve_ x1) up p x x0 + +(** val accb_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res **) +let accb_store up p x x0 x1 = + helper_def_store (fun x2 _ -> accb_store_ x2) up p x x0 x1 + +(** val accb_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let accb_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> accb_retrieve_ x1) up p x x0 + +(** val accb_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let accb_arg_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> accb_arg_retrieve_ x1) up p x x0 + +(** val dpl_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res **) +let dpl_store up p x x0 x1 = + helper_def_store (fun x2 _ -> dpl_store_ x2) up p x x0 x1 + +(** val dpl_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let dpl_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> dpl_retrieve_ x1) up p x x0 + +(** val dpl_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let dpl_arg_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> dpl_arg_retrieve_ x1) up p x x0 + +(** val dph_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res **) +let dph_store up p x x0 x1 = + helper_def_store (fun x2 _ -> dph_store_ x2) up p x x0 x1 + +(** val dph_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let dph_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> dph_retrieve_ x1) up p x x0 + +(** val dph_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let dph_arg_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> dph_arg_retrieve_ x1) up p x x0 + +(** val snd_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> ByteValues.beval Errors.res **) +let snd_arg_retrieve up p x x0 = + helper_def_retrieve (fun x1 _ -> snd_arg_retrieve_ x1) up p x x0 + +(** val pair_reg_move : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ + -> __ **) +let pair_reg_move up p st pm = + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (p.pair_reg_move_ st.regs pm)) (fun r -> + Monad.m_return0 (Monad.max_def Errors.res0) (set_regs p.st_pars r st)) + +(** val push : + sem_state_params -> state -> ByteValues.beval -> state Errors.res **) +let push p st v = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (is_push st.istack v)) (fun is -> + Monad.m_return0 (Monad.max_def Errors.res0) (set_istack p is st))) + +(** val pop : + sem_state_params -> state -> (ByteValues.beval, state) Types.prod + Errors.res **) +let pop p st = + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) (Obj.magic (is_pop st.istack)) + (fun bv is -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = bv; + Types.snd = (set_istack p is st) })) + +(** val push_ra : + sem_state_params -> state -> ByteValues.program_counter -> state + Errors.res **) +let push_ra p st l = + let { Types.fst = addrl; Types.snd = addrh } = + ByteValues.beval_pair_of_pc l + in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic (push p st addrl)) + (fun st' -> Obj.magic (push p st' addrh))) + +(** val pop_ra : + sem_state_params -> state -> (state, ByteValues.program_counter) + Types.prod Errors.res **) +let pop_ra p st = + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) (Obj.magic (pop p st)) + (fun addrh st' -> + Monad.m_bind2 (Monad.max_def Errors.res0) (Obj.magic (pop p st')) + (fun addrl st'' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (ByteValues.pc_of_bevals (List.Cons (addrl, (List.Cons (addrh, + List.Nil)))))) (fun pr -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = st''; + Types.snd = pr })))) + +type serialized_params = { spp : Joint.params; + msu_pars : Joint.joint_closed_internal_function + sem_unserialized_params; + offset_of_point : (__ -> Positive.pos); + point_of_offset : (Positive.pos -> __) } + +(** val serialized_params_rect_Type4 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) + -> __ -> __ -> 'a1) -> serialized_params -> 'a1 **) +let rec serialized_params_rect_Type4 h_mk_serialized_params x_24799 = + let { spp = spp0; msu_pars = msu_pars0; offset_of_point = offset_of_point0; + point_of_offset = point_of_offset0 } = x_24799 + in + h_mk_serialized_params spp0 msu_pars0 offset_of_point0 point_of_offset0 __ + __ + +(** val serialized_params_rect_Type5 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) + -> __ -> __ -> 'a1) -> serialized_params -> 'a1 **) +let rec serialized_params_rect_Type5 h_mk_serialized_params x_24801 = + let { spp = spp0; msu_pars = msu_pars0; offset_of_point = offset_of_point0; + point_of_offset = point_of_offset0 } = x_24801 + in + h_mk_serialized_params spp0 msu_pars0 offset_of_point0 point_of_offset0 __ + __ + +(** val serialized_params_rect_Type3 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) + -> __ -> __ -> 'a1) -> serialized_params -> 'a1 **) +let rec serialized_params_rect_Type3 h_mk_serialized_params x_24803 = + let { spp = spp0; msu_pars = msu_pars0; offset_of_point = offset_of_point0; + point_of_offset = point_of_offset0 } = x_24803 + in + h_mk_serialized_params spp0 msu_pars0 offset_of_point0 point_of_offset0 __ + __ + +(** val serialized_params_rect_Type2 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) + -> __ -> __ -> 'a1) -> serialized_params -> 'a1 **) +let rec serialized_params_rect_Type2 h_mk_serialized_params x_24805 = + let { spp = spp0; msu_pars = msu_pars0; offset_of_point = offset_of_point0; + point_of_offset = point_of_offset0 } = x_24805 + in + h_mk_serialized_params spp0 msu_pars0 offset_of_point0 point_of_offset0 __ + __ + +(** val serialized_params_rect_Type1 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) + -> __ -> __ -> 'a1) -> serialized_params -> 'a1 **) +let rec serialized_params_rect_Type1 h_mk_serialized_params x_24807 = + let { spp = spp0; msu_pars = msu_pars0; offset_of_point = offset_of_point0; + point_of_offset = point_of_offset0 } = x_24807 + in + h_mk_serialized_params spp0 msu_pars0 offset_of_point0 point_of_offset0 __ + __ + +(** val serialized_params_rect_Type0 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) + -> __ -> __ -> 'a1) -> serialized_params -> 'a1 **) +let rec serialized_params_rect_Type0 h_mk_serialized_params x_24809 = + let { spp = spp0; msu_pars = msu_pars0; offset_of_point = offset_of_point0; + point_of_offset = point_of_offset0 } = x_24809 + in + h_mk_serialized_params spp0 msu_pars0 offset_of_point0 point_of_offset0 __ + __ + +(** val spp : serialized_params -> Joint.params **) +let rec spp xxx = + xxx.spp + +(** val msu_pars : + serialized_params -> Joint.joint_closed_internal_function + sem_unserialized_params **) +let rec msu_pars xxx = + xxx.msu_pars + +(** val offset_of_point : serialized_params -> __ -> Positive.pos **) +let rec offset_of_point xxx = + xxx.offset_of_point + +(** val point_of_offset : serialized_params -> Positive.pos -> __ **) +let rec point_of_offset xxx = + xxx.point_of_offset + +(** val serialized_params_inv_rect_Type4 : + serialized_params -> (Joint.params -> + Joint.joint_closed_internal_function sem_unserialized_params -> (__ -> + Positive.pos) -> (Positive.pos -> __) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let serialized_params_inv_rect_Type4 hterm h1 = + let hcut = serialized_params_rect_Type4 h1 hterm in hcut __ + +(** val serialized_params_inv_rect_Type3 : + serialized_params -> (Joint.params -> + Joint.joint_closed_internal_function sem_unserialized_params -> (__ -> + Positive.pos) -> (Positive.pos -> __) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let serialized_params_inv_rect_Type3 hterm h1 = + let hcut = serialized_params_rect_Type3 h1 hterm in hcut __ + +(** val serialized_params_inv_rect_Type2 : + serialized_params -> (Joint.params -> + Joint.joint_closed_internal_function sem_unserialized_params -> (__ -> + Positive.pos) -> (Positive.pos -> __) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let serialized_params_inv_rect_Type2 hterm h1 = + let hcut = serialized_params_rect_Type2 h1 hterm in hcut __ + +(** val serialized_params_inv_rect_Type1 : + serialized_params -> (Joint.params -> + Joint.joint_closed_internal_function sem_unserialized_params -> (__ -> + Positive.pos) -> (Positive.pos -> __) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let serialized_params_inv_rect_Type1 hterm h1 = + let hcut = serialized_params_rect_Type1 h1 hterm in hcut __ + +(** val serialized_params_inv_rect_Type0 : + serialized_params -> (Joint.params -> + Joint.joint_closed_internal_function sem_unserialized_params -> (__ -> + Positive.pos) -> (Positive.pos -> __) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let serialized_params_inv_rect_Type0 hterm h1 = + let hcut = serialized_params_rect_Type0 h1 hterm in hcut __ + +(** val serialized_params_jmdiscr : + serialized_params -> serialized_params -> __ **) +let serialized_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { spp = a0; msu_pars = a1; offset_of_point = a2; point_of_offset = + a3 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val spp__o__stmt_pars : serialized_params -> Joint.stmt_params **) +let spp__o__stmt_pars x0 = + x0.spp.Joint.stmt_pars + +(** val spp__o__stmt_pars__o__uns_pars : + serialized_params -> Joint.uns_params **) +let spp__o__stmt_pars__o__uns_pars x0 = + Joint.stmt_pars__o__uns_pars x0.spp + +(** val spp__o__stmt_pars__o__uns_pars__o__u_pars : + serialized_params -> Joint.unserialized_params **) +let spp__o__stmt_pars__o__uns_pars__o__u_pars x0 = + Joint.stmt_pars__o__uns_pars__o__u_pars x0.spp + +(** val msu_pars__o__st_pars : serialized_params -> sem_state_params **) +let msu_pars__o__st_pars x0 = + x0.msu_pars.st_pars + +type sem_params = { spp' : serialized_params; + pre_main_generator : (Joint.joint_program -> + Joint.joint_closed_internal_function) } + +(** val sem_params_rect_Type4 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 **) +let rec sem_params_rect_Type4 h_mk_sem_params x_24827 = + let { spp' = spp'0; pre_main_generator = pre_main_generator0 } = x_24827 in + h_mk_sem_params spp'0 pre_main_generator0 + +(** val sem_params_rect_Type5 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 **) +let rec sem_params_rect_Type5 h_mk_sem_params x_24829 = + let { spp' = spp'0; pre_main_generator = pre_main_generator0 } = x_24829 in + h_mk_sem_params spp'0 pre_main_generator0 + +(** val sem_params_rect_Type3 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 **) +let rec sem_params_rect_Type3 h_mk_sem_params x_24831 = + let { spp' = spp'0; pre_main_generator = pre_main_generator0 } = x_24831 in + h_mk_sem_params spp'0 pre_main_generator0 + +(** val sem_params_rect_Type2 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 **) +let rec sem_params_rect_Type2 h_mk_sem_params x_24833 = + let { spp' = spp'0; pre_main_generator = pre_main_generator0 } = x_24833 in + h_mk_sem_params spp'0 pre_main_generator0 + +(** val sem_params_rect_Type1 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 **) +let rec sem_params_rect_Type1 h_mk_sem_params x_24835 = + let { spp' = spp'0; pre_main_generator = pre_main_generator0 } = x_24835 in + h_mk_sem_params spp'0 pre_main_generator0 + +(** val sem_params_rect_Type0 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 **) +let rec sem_params_rect_Type0 h_mk_sem_params x_24837 = + let { spp' = spp'0; pre_main_generator = pre_main_generator0 } = x_24837 in + h_mk_sem_params spp'0 pre_main_generator0 + +(** val spp' : sem_params -> serialized_params **) +let rec spp' xxx = + xxx.spp' + +(** val pre_main_generator : + sem_params -> Joint.joint_program -> Joint.joint_closed_internal_function **) +let rec pre_main_generator xxx = + xxx.pre_main_generator + +(** val sem_params_inv_rect_Type4 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_params_inv_rect_Type4 hterm h1 = + let hcut = sem_params_rect_Type4 h1 hterm in hcut __ + +(** val sem_params_inv_rect_Type3 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_params_inv_rect_Type3 hterm h1 = + let hcut = sem_params_rect_Type3 h1 hterm in hcut __ + +(** val sem_params_inv_rect_Type2 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_params_inv_rect_Type2 hterm h1 = + let hcut = sem_params_rect_Type2 h1 hterm in hcut __ + +(** val sem_params_inv_rect_Type1 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_params_inv_rect_Type1 hterm h1 = + let hcut = sem_params_rect_Type1 h1 hterm in hcut __ + +(** val sem_params_inv_rect_Type0 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_params_inv_rect_Type0 hterm h1 = + let hcut = sem_params_rect_Type0 h1 hterm in hcut __ + +(** val sem_params_jmdiscr : sem_params -> sem_params -> __ **) +let sem_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { spp' = a0; pre_main_generator = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val spp'__o__msu_pars : + sem_params -> Joint.joint_closed_internal_function + sem_unserialized_params **) +let spp'__o__msu_pars x0 = + x0.spp'.msu_pars + +(** val spp'__o__msu_pars__o__st_pars : sem_params -> sem_state_params **) +let spp'__o__msu_pars__o__st_pars x0 = + msu_pars__o__st_pars x0.spp' + +(** val spp'__o__spp : sem_params -> Joint.params **) +let spp'__o__spp x0 = + x0.spp'.spp + +(** val spp'__o__spp__o__stmt_pars : sem_params -> Joint.stmt_params **) +let spp'__o__spp__o__stmt_pars x0 = + spp__o__stmt_pars x0.spp' + +(** val spp'__o__spp__o__stmt_pars__o__uns_pars : + sem_params -> Joint.uns_params **) +let spp'__o__spp__o__stmt_pars__o__uns_pars x0 = + spp__o__stmt_pars__o__uns_pars x0.spp' + +(** val spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + sem_params -> Joint.unserialized_params **) +let spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars x0 = + spp__o__stmt_pars__o__uns_pars__o__u_pars x0.spp' + +(** val pc_of_point : + sem_params -> Pointers.block Types.sig0 -> __ -> + ByteValues.program_counter **) +let pc_of_point p bl pt = + { ByteValues.pc_block = bl; ByteValues.pc_offset = + (p.spp'.offset_of_point pt) } + +(** val point_of_pc : sem_params -> ByteValues.program_counter -> __ **) +let point_of_pc p ptr = + p.spp'.point_of_offset ptr.ByteValues.pc_offset + +(** val fetch_statement : + sem_params -> AST.ident List.list -> genv -> ByteValues.program_counter + -> ((AST.ident, Joint.joint_closed_internal_function) Types.prod, + Joint.joint_statement) Types.prod Errors.res **) +let fetch_statement p globals ge0 ptr = + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (fetch_internal_function globals ge0 ptr.ByteValues.pc_block)) + (fun id fn -> + let pt = point_of_pc p ptr in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res + (Errors.msg ErrorMessages.ProgramCounterOutOfCode) + ((spp'__o__spp p).Joint.stmt_at globals + (Types.pi1 fn).Joint.joint_if_code pt))) (fun stmt -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + { Types.fst = id; Types.snd = fn }; Types.snd = stmt }))) + +(** val pc_of_label : + sem_params -> AST.ident List.list -> genv -> Pointers.block Types.sig0 -> + Graphs.label -> ByteValues.program_counter Errors.res **) +let pc_of_label p globals ge0 bl lbl = + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (fetch_internal_function globals ge0 bl)) (fun i fn -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.LabelNotFound), (List.Cons ((Errors.CTX + (PreIdentifiers.LabelTag, lbl)), List.Nil)))) + ((spp'__o__spp p).Joint.point_of_label globals + (Types.pi1 fn).Joint.joint_if_code lbl))) (fun pt -> + Monad.m_return0 (Monad.max_def Errors.res0) { ByteValues.pc_block = + bl; ByteValues.pc_offset = (p.spp'.offset_of_point pt) }))) + +(** val succ_pc : + sem_params -> ByteValues.program_counter -> __ -> + ByteValues.program_counter **) +let succ_pc p ptr nxt = + let curr = point_of_pc p ptr in + pc_of_point p ptr.ByteValues.pc_block + ((spp'__o__spp p).Joint.point_of_succ curr nxt) + +(** val goto : + sem_params -> AST.ident List.list -> genv -> Graphs.label -> state_pc -> + state_pc Errors.res **) +let goto p globals ge0 l st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (pc_of_label p globals ge0 st.pc.ByteValues.pc_block l)) + (fun newpc -> + Monad.m_return0 (Monad.max_def Errors.res0) + (set_pc (spp'__o__msu_pars__o__st_pars p) newpc st))) + +(** val next : sem_params -> __ -> state_pc -> state_pc **) +let next p l st = + let newpc = succ_pc p st.pc l in + set_pc (spp'__o__msu_pars__o__st_pars p) newpc st + +(** val next_of_call_pc : + sem_params -> AST.ident List.list -> genv -> ByteValues.program_counter + -> __ Errors.res **) +let next_of_call_pc p globals ge0 pc0 = + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (fetch_statement p globals ge0 pc0)) (fun id_fn stmt -> + match stmt with + | Joint.Sequential (s, nxt) -> + (match s with + | Joint.COST_LABEL x -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.NoSuccessor), List.Nil))) + | Joint.CALL (x, x0, x1) -> + Monad.m_return0 (Monad.max_def Errors.res0) nxt + | Joint.COND (x, x0) -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.NoSuccessor), List.Nil))) + | Joint.Step_seq x -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.NoSuccessor), List.Nil)))) + | Joint.Final x -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.NoSuccessor), List.Nil))) + | Joint.FCOND (x0, x1, x2) -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.NoSuccessor), List.Nil))))) + +(** val eval_seq_no_pc : + sem_params -> AST.ident List.list -> genv -> AST.ident -> Joint.joint_seq + -> state -> state Errors.res **) +let eval_seq_no_pc p globals ge0 curr_id seq st = + match seq with + | Joint.COMMENT x -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st) + | Joint.MOVE dst_src -> + Obj.magic + (pair_reg_move (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st dst_src) + | Joint.POP dst -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (pop (spp'__o__msu_pars__o__st_pars p) st)) (fun v st' -> + Obj.magic + (acca_store (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + (spp'__o__msu_pars p) dst v st'))) + | Joint.PUSH src -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st src)) (fun v -> + Obj.magic (push (spp'__o__msu_pars__o__st_pars p) st v))) + | Joint.ADDRESS (id, off, ldest, hdest) -> + let addr_block = Option.opt_safe (Globalenvs.find_symbol ge0.ge id) in + let { Types.fst = laddr; Types.snd = haddr } = + ByteValues.beval_pair_of_pointer { Pointers.pblock = addr_block; + Pointers.poff = off } + in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (dpl_store (spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars p) + p.spp'.msu_pars ldest laddr st)) (fun st' -> + Obj.magic + (dph_store (spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars p) + p.spp'.msu_pars hdest haddr st'))) + | Joint.OPACCS (op, dacc_a_reg, dacc_b_reg, sacc_a_reg, sacc_b_reg) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st sacc_a_reg)) (fun v1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (accb_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st sacc_b_reg)) (fun v2 -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (BackEndOps.be_opaccs op v1 v2)) (fun v1' v2' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_store + (spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars p) + p.spp'.msu_pars dacc_a_reg v1' st)) (fun st' -> + Obj.magic + (accb_store + (spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars p) + p.spp'.msu_pars dacc_b_reg v2' st')))))) + | Joint.OP1 (op, dacc_a, sacc_a) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_retrieve (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st sacc_a)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (BackEndOps.be_op1 op v)) (fun v' -> + Obj.magic + (acca_store + (spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars p) + p.spp'.msu_pars dacc_a v' st)))) + | Joint.OP2 (op, dacc_a, sacc_a, src) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st sacc_a)) (fun v1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (snd_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st src)) (fun v2 -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (BackEndOps.be_op2 st.carry op v1 v2)) + (fun v' carry0 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_store + (spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars p) + p.spp'.msu_pars dacc_a v' st)) (fun st' -> + Monad.m_return0 (Monad.max_def Errors.res0) + (set_carry p.spp'.msu_pars.st_pars carry0 st')))))) + | Joint.CLEAR_CARRY -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + (set_carry (spp'__o__msu_pars__o__st_pars p) (ByteValues.BBbit + Bool.False) st)) + | Joint.SET_CARRY -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + (set_carry (spp'__o__msu_pars__o__st_pars p) (ByteValues.BBbit + Bool.True) st)) + | Joint.LOAD (dst, addrl, addrh) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (dph_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st addrh)) (fun vaddrh -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (dpl_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st addrl)) (fun vaddrl -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (BEMem.pointer_of_address { Types.fst = vaddrl; Types.snd = + vaddrh })) (fun vaddr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (GenMem.beloadv st.m vaddr))) (fun v -> + Obj.magic + (acca_store + (spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars p) + p.spp'.msu_pars dst v st)))))) + | Joint.STORE (addrl, addrh, src) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (dph_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st addrh)) (fun vaddrh -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (dpl_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st addrl)) (fun vaddrl -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (BEMem.pointer_of_address { Types.fst = vaddrl; Types.snd = + vaddrh })) (fun vaddr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st src)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedStore) + (GenMem.bestorev st.m vaddr v))) (fun m' -> + Monad.m_return0 (Monad.max_def Errors.res0) + (set_m (spp'__o__msu_pars__o__st_pars p) m' st))))))) + | Joint.Extension_seq c -> + p.spp'.msu_pars.eval_ext_seq globals ge0 c curr_id st + +(** val block_of_call : + sem_params -> AST.ident List.list -> genv -> (PreIdentifiers.identifier, + (__, __) Types.prod) Types.sum -> state -> __ **) +let block_of_call p globals ge0 f st = + Monad.m_bind0 (Monad.max_def Errors.res0) + (match f with + | Types.Inl id -> + Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Globalenvs.find_symbol ge0.ge id)) + | Types.Inr addr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (dpl_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st addr.Types.fst)) (fun addr_l -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (dph_arg_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st addr.Types.snd)) (fun addr_h -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (ByteValues.pointer_of_bevals (List.Cons (addr_l, (List.Cons + (addr_h, List.Nil)))))) (fun ptr -> + match BitVector.eq_bv Pointers.offset_size + (BitVector.zero Pointers.offset_size) + (Pointers.offv ptr.Pointers.poff) with + | Bool.True -> + Monad.m_return0 (Monad.max_def Errors.res0) + ptr.Pointers.pblock + | Bool.False -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.MSG + ErrorMessages.BadPointer), List.Nil))))))))) (fun bl -> + Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG ErrorMessages.BadFunction), + (List.Cons ((Errors.MSG ErrorMessages.BadPointer), List.Nil)))) + (code_block_of_block bl))) + +(** val eval_external_call : + sem_params -> AST.external_function -> __ -> __ -> state -> __ **) +let eval_external_call p fn args dest st = + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (let x = + IOMonad.err_to_io + ((spp'__o__msu_pars p).fetch_external_args fn st args) + in + Obj.magic x) (fun params -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (let x = + IOMonad.err_to_io + (IO.check_eventval_list params fn.AST.ef_sig.AST.sig_args) + in + Obj.magic x) (fun evargs -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IO.do_io fn.AST.ef_id evargs (AST.proj_sig_res fn.AST.ef_sig))) + (fun evres -> + let vs = List.Cons + ((IO.mk_val (AST.proj_sig_res fn.AST.ef_sig) evres), List.Nil) + in + Obj.magic + (IOMonad.err_to_io ((spp'__o__msu_pars p).set_result vs dest st))))) + +(** val increment_stack_usage : + sem_state_params -> Nat.nat -> state -> state **) +let increment_stack_usage p n st = + { st_frms = st.st_frms; istack = st.istack; carry = st.carry; regs = + st.regs; m = st.m; stack_usage = (Nat.plus n st.stack_usage) } + +(** val decrement_stack_usage : + sem_state_params -> Nat.nat -> state -> state **) +let decrement_stack_usage p n st = + { st_frms = st.st_frms; istack = st.istack; carry = st.carry; regs = + st.regs; m = st.m; stack_usage = (Nat.minus st.stack_usage n) } + +(** val eval_internal_call : + sem_params -> AST.ident List.list -> genv -> PreIdentifiers.identifier -> + Joint.joint_internal_function -> __ -> state -> __ **) +let eval_internal_call p globals ge0 i fn args st = + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingStackSize), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, i)), List.Nil)))) (ge0.stack_sizes i))) + (fun stack_size -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (p.spp'.msu_pars.setup_call stack_size fn.Joint.joint_if_params args + st)) (fun st' -> + Monad.m_return0 (Monad.max_def Errors.res0) + (increment_stack_usage p.spp'.msu_pars.st_pars stack_size st'))) + +(** val is_inl : ('a1, 'a2) Types.sum -> Bool.bool **) +let is_inl = function +| Types.Inl x0 -> Bool.True +| Types.Inr x0 -> Bool.False + +(** val eval_call : + sem_params -> AST.ident List.list -> genv -> (PreIdentifiers.identifier, + (__, __) Types.prod) Types.sum -> __ -> __ -> __ -> state_pc -> __ **) +let eval_call p globals ge0 f args dest nxt st = + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (let x = + IOMonad.err_to_io + (Obj.magic (block_of_call p globals ge0 f st.st_no_pc)) + in + Obj.magic x) (fun bl -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (fetch_function globals ge0 bl) in + Obj.magic x) (fun i fd -> + match fd with + | AST.Internal ifd -> + Obj.magic + (IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (p.spp'.msu_pars.save_frame + (kind_of_call + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) f) + dest st)) (fun st' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (eval_internal_call p globals ge0 i (Types.pi1 ifd) args + st') (fun st'' -> + let pc0 = + pc_of_point p bl (Types.pi1 ifd).Joint.joint_if_entry + in + Monad.m_return0 (Monad.max_def Errors.res0) { st_no_pc = + st''; pc = pc0; last_pop = st.last_pop }))))) + | AST.External efd -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (eval_external_call p efd args dest st.st_no_pc) (fun st' -> + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { st_no_pc = st'; + pc = (succ_pc p st.pc nxt); last_pop = st.last_pop }))) + +(** val eval_statement_no_pc : + sem_params -> AST.ident List.list -> genv -> AST.ident -> + Joint.joint_statement -> state -> state Errors.res **) +let eval_statement_no_pc p globals ge0 curr_id s st = + match s with + | Joint.Sequential (s0, next0) -> + (match s0 with + | Joint.COST_LABEL x -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st) + | Joint.CALL (x, x0, x1) -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st) + | Joint.COND (x, x0) -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st) + | Joint.Step_seq s1 -> eval_seq_no_pc p globals ge0 curr_id s1 st) + | Joint.Final x -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st) + | Joint.FCOND (x0, x1, x2) -> + Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st) + +(** val eval_return : + sem_params -> AST.ident List.list -> genv -> PreIdentifiers.identifier -> + __ -> state -> __ **) +let eval_return p globals ge0 curr_id curr_ret st = + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingStackSize), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, curr_id)), List.Nil)))) + (ge0.stack_sizes curr_id))) (fun stack_size -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (p.spp'.msu_pars.pop_frame globals ge0 curr_id curr_ret st)) + (fun st' call_pc -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (next_of_call_pc p globals ge0 call_pc)) (fun nxt -> + let st'' = + set_last_pop p.spp'.msu_pars.st_pars + (decrement_stack_usage p.spp'.msu_pars.st_pars stack_size st') + call_pc + in + Monad.m_return0 (Monad.max_def Errors.res0) (next p nxt st'')))) + +(** val eval_tailcall : + sem_params -> AST.ident List.list -> genv -> (PreIdentifiers.identifier, + (__, __) Types.prod) Types.sum -> __ -> PreIdentifiers.identifier -> __ + -> state_pc -> __ **) +let eval_tailcall p globals ge0 f args curr_f curr_ret st = + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (let x = + IOMonad.err_to_io + (Obj.magic (block_of_call p globals ge0 f st.st_no_pc)) + in + Obj.magic x) (fun bl -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (fetch_function globals ge0 bl) in + Obj.magic x) (fun i fd -> + match fd with + | AST.Internal ifd -> + Obj.magic + (IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingStackSize), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, curr_f)), List.Nil)))) + (ge0.stack_sizes curr_f))) (fun stack_size -> + let st' = + decrement_stack_usage (spp'__o__msu_pars__o__st_pars p) + stack_size st.st_no_pc + in + Monad.m_bind0 (Monad.max_def Errors.res0) + (eval_internal_call p globals ge0 i (Types.pi1 ifd) args + st') (fun st'' -> + let pc0 = + pc_of_point p bl (Types.pi1 ifd).Joint.joint_if_entry + in + Monad.m_return0 (Monad.max_def Errors.res0) { st_no_pc = + st''; pc = pc0; last_pop = st.last_pop }))))) + | AST.External efd -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (eval_external_call p efd args curr_ret st.st_no_pc) (fun st' -> + Obj.magic + (IOMonad.err_to_io + (Obj.magic + (eval_return p globals ge0 curr_f curr_ret st.st_no_pc)))))) + +(** val eval_statement_advance : + sem_params -> AST.ident List.list -> genv -> AST.ident -> + Joint.joint_closed_internal_function -> Joint.joint_statement -> state_pc + -> (IO.io_out, IO.io_in, state_pc) IOMonad.iO **) +let eval_statement_advance p g ge0 curr_id curr_fn s st = + match s with + | Joint.Sequential (s0, nxt) -> + (match s0 with + | Joint.COST_LABEL x -> + Obj.magic + (Monad.m_return0 (Monad.max_def IOMonad.iOMonad) (next p nxt st)) + | Joint.CALL (f, args, dest) -> + Obj.magic (eval_call p g ge0 f args dest nxt st) + | Joint.COND (a, l) -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st.st_no_pc a)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ByteValues.bool_of_beval v)) (fun b -> + match b with + | Bool.True -> Obj.magic (goto p g ge0 l st) + | Bool.False -> + Monad.m_return0 (Monad.max_def Errors.res0) (next p nxt st))))) + | Joint.Step_seq x -> + Obj.magic + (Monad.m_return0 (Monad.max_def IOMonad.iOMonad) (next p nxt st))) + | Joint.Final s0 -> + let curr_ret = (Types.pi1 curr_fn).Joint.joint_if_result in + (match s0 with + | Joint.GOTO l -> IOMonad.err_to_io (goto p g ge0 l st) + | Joint.RETURN -> + IOMonad.err_to_io + (Obj.magic (eval_return p g ge0 curr_id curr_ret st.st_no_pc)) + | Joint.TAILCALL (f, args) -> + Obj.magic (eval_tailcall p g ge0 f args curr_id curr_ret st)) + | Joint.FCOND (a, lbltrue, lblfalse) -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (acca_retrieve + (Joint.stmt_pars__o__uns_pars__o__u_pars p.spp'.spp) + p.spp'.msu_pars st.st_no_pc a)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (ByteValues.bool_of_beval v)) (fun b -> + match b with + | Bool.True -> Obj.magic (goto p g ge0 lbltrue st) + | Bool.False -> Obj.magic (goto p g ge0 lblfalse st))))) + +(** val eval_state : + sem_params -> AST.ident List.list -> genv -> state_pc -> (IO.io_out, + IO.io_in, state_pc) IOMonad.iO **) +let eval_state p globals ge0 st = + Obj.magic + (Monad.m_bind3 (Monad.max_def IOMonad.iOMonad) + (let x = IOMonad.err_to_io (fetch_statement p globals ge0 st.pc) in + Obj.magic x) (fun id fn s -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (let x = + IOMonad.err_to_io + (eval_statement_no_pc p globals ge0 id s st.st_no_pc) + in + Obj.magic x) (fun st' -> + let st'' = set_no_pc (spp'__o__msu_pars__o__st_pars p) st' st in + Obj.magic (eval_statement_advance p globals ge0 id fn s st'')))) + diff --git a/extracted/joint_semantics.mli b/extracted/joint_semantics.mli new file mode 100644 index 0000000..abea7eb --- /dev/null +++ b/extracted/joint_semantics.mli @@ -0,0 +1,1294 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open CostLabel + +open Events + +open IOMonad + +open IO + +open BEMem + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open I8051bis + +open ExtraGlobalenvs + +type 'f genv_gen = { ge : 'f AST.fundef Globalenvs.genv_t; + stack_sizes : (AST.ident -> Nat.nat Types.option); + premain : 'f; + pc_from_label : (Pointers.block Types.sig0 -> 'f -> + Graphs.label -> + ByteValues.program_counter Types.option) } + +val genv_gen_rect_Type4 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 -> + 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> 'a2) -> + 'a1 genv_gen -> 'a2 + +val genv_gen_rect_Type5 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 -> + 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> 'a2) -> + 'a1 genv_gen -> 'a2 + +val genv_gen_rect_Type3 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 -> + 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> 'a2) -> + 'a1 genv_gen -> 'a2 + +val genv_gen_rect_Type2 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 -> + 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> 'a2) -> + 'a1 genv_gen -> 'a2 + +val genv_gen_rect_Type1 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 -> + 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> 'a2) -> + 'a1 genv_gen -> 'a2 + +val genv_gen_rect_Type0 : + AST.ident List.list -> ('a1 AST.fundef Globalenvs.genv_t -> __ -> + (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block Types.sig0 -> + 'a1 -> Graphs.label -> ByteValues.program_counter Types.option) -> 'a2) -> + 'a1 genv_gen -> 'a2 + +val ge : + AST.ident List.list -> 'a1 genv_gen -> 'a1 AST.fundef Globalenvs.genv_t + +val stack_sizes : + AST.ident List.list -> 'a1 genv_gen -> AST.ident -> Nat.nat Types.option + +val premain : AST.ident List.list -> 'a1 genv_gen -> 'a1 + +val pc_from_label : + AST.ident List.list -> 'a1 genv_gen -> Pointers.block Types.sig0 -> 'a1 -> + Graphs.label -> ByteValues.program_counter Types.option + +val genv_gen_inv_rect_Type4 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t -> + __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 + +val genv_gen_inv_rect_Type3 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t -> + __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 + +val genv_gen_inv_rect_Type2 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t -> + __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 + +val genv_gen_inv_rect_Type1 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t -> + __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 + +val genv_gen_inv_rect_Type0 : + AST.ident List.list -> 'a1 genv_gen -> ('a1 AST.fundef Globalenvs.genv_t -> + __ -> (AST.ident -> Nat.nat Types.option) -> 'a1 -> (Pointers.block + Types.sig0 -> 'a1 -> Graphs.label -> ByteValues.program_counter + Types.option) -> __ -> 'a2) -> 'a2 + +val genv_gen_discr : + AST.ident List.list -> 'a1 genv_gen -> 'a1 genv_gen -> __ + +val genv_gen_jmdiscr : + AST.ident List.list -> 'a1 genv_gen -> 'a1 genv_gen -> __ + +val dpi1__o__ge__o__inject : + AST.ident List.list -> ('a1 genv_gen, 'a2) Types.dPair -> 'a1 AST.fundef + Globalenvs.genv_t Types.sig0 + +val eject__o__ge__o__inject : + AST.ident List.list -> 'a1 genv_gen Types.sig0 -> 'a1 AST.fundef + Globalenvs.genv_t Types.sig0 + +val ge__o__inject : + AST.ident List.list -> 'a1 genv_gen -> 'a1 AST.fundef Globalenvs.genv_t + Types.sig0 + +val dpi1__o__ge : + AST.ident List.list -> ('a1 genv_gen, 'a2) Types.dPair -> 'a1 AST.fundef + Globalenvs.genv_t + +val eject__o__ge : + AST.ident List.list -> 'a1 genv_gen Types.sig0 -> 'a1 AST.fundef + Globalenvs.genv_t + +val pre_main_id : AST.ident + +val fetch_function : + AST.ident List.list -> 'a1 genv_gen -> Pointers.block Types.sig0 -> + (AST.ident, 'a1 AST.fundef) Types.prod Errors.res + +val fetch_internal_function : + AST.ident List.list -> 'a1 genv_gen -> Pointers.block Types.sig0 -> + (AST.ident, 'a1) Types.prod Errors.res + +val code_block_of_block : + Pointers.block -> Pointers.block Types.sig0 Types.option + +val block_of_funct_id : + 'a1 Globalenvs.genv_t -> PreIdentifiers.identifier -> Pointers.block + Types.sig0 Errors.res + +val gen_pc_from_label : + AST.ident List.list -> 'a1 genv_gen -> AST.ident -> Graphs.label -> + ByteValues.program_counter Errors.res + +type genv = Joint.joint_closed_internal_function genv_gen + +type sem_state_params = { empty_framesT : __; + empty_regsT : (ByteValues.xpointer -> __); + load_sp : (__ -> ByteValues.xpointer Errors.res); + save_sp : (__ -> ByteValues.xpointer -> __) } + +val sem_state_params_rect_Type4 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 + +val sem_state_params_rect_Type5 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 + +val sem_state_params_rect_Type3 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 + +val sem_state_params_rect_Type2 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 + +val sem_state_params_rect_Type1 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 + +val sem_state_params_rect_Type0 : + (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ -> + ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + 'a1) -> sem_state_params -> 'a1 + +type framesT + +val empty_framesT : sem_state_params -> __ + +type regsT + +val empty_regsT : sem_state_params -> ByteValues.xpointer -> __ + +val load_sp : sem_state_params -> __ -> ByteValues.xpointer Errors.res + +val save_sp : sem_state_params -> __ -> ByteValues.xpointer -> __ + +val sem_state_params_inv_rect_Type4 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + __ -> 'a1) -> 'a1 + +val sem_state_params_inv_rect_Type3 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + __ -> 'a1) -> 'a1 + +val sem_state_params_inv_rect_Type2 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + __ -> 'a1) -> 'a1 + +val sem_state_params_inv_rect_Type1 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + __ -> 'a1) -> 'a1 + +val sem_state_params_inv_rect_Type0 : + sem_state_params -> (__ -> __ -> __ -> (ByteValues.xpointer -> __) -> (__ + -> ByteValues.xpointer Errors.res) -> (__ -> ByteValues.xpointer -> __) -> + __ -> 'a1) -> 'a1 + +val sem_state_params_jmdiscr : sem_state_params -> sem_state_params -> __ + +type internal_stack = +| Empty_is +| One_is of ByteValues.beval +| Both_is of ByteValues.beval * ByteValues.beval + +val internal_stack_rect_Type4 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 + +val internal_stack_rect_Type5 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 + +val internal_stack_rect_Type3 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 + +val internal_stack_rect_Type2 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 + +val internal_stack_rect_Type1 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 + +val internal_stack_rect_Type0 : + 'a1 -> (ByteValues.beval -> 'a1) -> (ByteValues.beval -> ByteValues.beval + -> 'a1) -> internal_stack -> 'a1 + +val internal_stack_inv_rect_Type4 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 + +val internal_stack_inv_rect_Type3 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 + +val internal_stack_inv_rect_Type2 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 + +val internal_stack_inv_rect_Type1 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 + +val internal_stack_inv_rect_Type0 : + internal_stack -> (__ -> 'a1) -> (ByteValues.beval -> __ -> 'a1) -> + (ByteValues.beval -> ByteValues.beval -> __ -> 'a1) -> 'a1 + +val internal_stack_discr : internal_stack -> internal_stack -> __ + +val internal_stack_jmdiscr : internal_stack -> internal_stack -> __ + +val is_push : internal_stack -> ByteValues.beval -> internal_stack Errors.res + +val is_pop : + internal_stack -> (ByteValues.beval, internal_stack) Types.prod Errors.res + +type state = { st_frms : __ Types.option; istack : internal_stack; + carry : ByteValues.bebit; regs : __; m : BEMem.bemem; + stack_usage : Nat.nat } + +val state_rect_Type4 : + sem_state_params -> (__ Types.option -> internal_stack -> ByteValues.bebit + -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 + +val state_rect_Type5 : + sem_state_params -> (__ Types.option -> internal_stack -> ByteValues.bebit + -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 + +val state_rect_Type3 : + sem_state_params -> (__ Types.option -> internal_stack -> ByteValues.bebit + -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 + +val state_rect_Type2 : + sem_state_params -> (__ Types.option -> internal_stack -> ByteValues.bebit + -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 + +val state_rect_Type1 : + sem_state_params -> (__ Types.option -> internal_stack -> ByteValues.bebit + -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 + +val state_rect_Type0 : + sem_state_params -> (__ Types.option -> internal_stack -> ByteValues.bebit + -> __ -> BEMem.bemem -> Nat.nat -> 'a1) -> state -> 'a1 + +val st_frms : sem_state_params -> state -> __ Types.option + +val istack : sem_state_params -> state -> internal_stack + +val carry : sem_state_params -> state -> ByteValues.bebit + +val regs : sem_state_params -> state -> __ + +val m : sem_state_params -> state -> BEMem.bemem + +val stack_usage : sem_state_params -> state -> Nat.nat + +val state_inv_rect_Type4 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type3 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type2 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type1 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type0 : + sem_state_params -> state -> (__ Types.option -> internal_stack -> + ByteValues.bebit -> __ -> BEMem.bemem -> Nat.nat -> __ -> 'a1) -> 'a1 + +val state_jmdiscr : sem_state_params -> state -> state -> __ + +val sp : sem_state_params -> state -> ByteValues.xpointer Errors.res + +type state_pc = { st_no_pc : state; pc : ByteValues.program_counter; + last_pop : ByteValues.program_counter } + +val state_pc_rect_Type4 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 + +val state_pc_rect_Type5 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 + +val state_pc_rect_Type3 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 + +val state_pc_rect_Type2 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 + +val state_pc_rect_Type1 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 + +val state_pc_rect_Type0 : + sem_state_params -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> 'a1) -> state_pc -> 'a1 + +val st_no_pc : sem_state_params -> state_pc -> state + +val pc : sem_state_params -> state_pc -> ByteValues.program_counter + +val last_pop : sem_state_params -> state_pc -> ByteValues.program_counter + +val state_pc_inv_rect_Type4 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 + +val state_pc_inv_rect_Type3 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 + +val state_pc_inv_rect_Type2 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 + +val state_pc_inv_rect_Type1 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 + +val state_pc_inv_rect_Type0 : + sem_state_params -> state_pc -> (state -> ByteValues.program_counter -> + ByteValues.program_counter -> __ -> 'a1) -> 'a1 + +val state_pc_discr : sem_state_params -> state_pc -> state_pc -> __ + +val state_pc_jmdiscr : sem_state_params -> state_pc -> state_pc -> __ + +val dpi1__o__st_no_pc__o__inject : + sem_state_params -> (state_pc, 'a1) Types.dPair -> state Types.sig0 + +val eject__o__st_no_pc__o__inject : + sem_state_params -> state_pc Types.sig0 -> state Types.sig0 + +val st_no_pc__o__inject : sem_state_params -> state_pc -> state Types.sig0 + +val dpi1__o__st_no_pc : + sem_state_params -> (state_pc, 'a1) Types.dPair -> state + +val eject__o__st_no_pc : sem_state_params -> state_pc Types.sig0 -> state + +val init_pc : ByteValues.program_counter + +val null_pc : Positive.pos -> ByteValues.program_counter + +val set_m : sem_state_params -> BEMem.bemem -> state -> state + +val set_regs : sem_state_params -> __ -> state -> state + +val set_sp : sem_state_params -> ByteValues.xpointer -> state -> state + +val set_carry : sem_state_params -> ByteValues.bebit -> state -> state + +val set_istack : sem_state_params -> internal_stack -> state -> state + +val set_pc : + sem_state_params -> ByteValues.program_counter -> state_pc -> state_pc + +val set_no_pc : sem_state_params -> state -> state_pc -> state_pc + +val set_last_pop : + sem_state_params -> state -> ByteValues.program_counter -> state_pc + +val set_frms : sem_state_params -> __ -> state -> state + +type call_kind = +| PTR +| ID + +val call_kind_rect_Type4 : 'a1 -> 'a1 -> call_kind -> 'a1 + +val call_kind_rect_Type5 : 'a1 -> 'a1 -> call_kind -> 'a1 + +val call_kind_rect_Type3 : 'a1 -> 'a1 -> call_kind -> 'a1 + +val call_kind_rect_Type2 : 'a1 -> 'a1 -> call_kind -> 'a1 + +val call_kind_rect_Type1 : 'a1 -> 'a1 -> call_kind -> 'a1 + +val call_kind_rect_Type0 : 'a1 -> 'a1 -> call_kind -> 'a1 + +val call_kind_inv_rect_Type4 : call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val call_kind_inv_rect_Type3 : call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val call_kind_inv_rect_Type2 : call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val call_kind_inv_rect_Type1 : call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val call_kind_inv_rect_Type0 : call_kind -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val call_kind_discr : call_kind -> call_kind -> __ + +val call_kind_jmdiscr : call_kind -> call_kind -> __ + +val kind_of_call : + Joint.unserialized_params -> (AST.ident, (__, __) Types.prod) Types.sum -> + call_kind + +type 'f sem_unserialized_params = { st_pars : sem_state_params; + acca_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + acca_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + acca_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + accb_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + accb_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + accb_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dpl_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + dpl_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dpl_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dph_store_ : (__ -> ByteValues.beval -> + __ -> __ Errors.res); + dph_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + dph_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + snd_arg_retrieve_ : (__ -> __ -> + ByteValues.beval + Errors.res); + pair_reg_move_ : (__ -> __ -> __ + Errors.res); + save_frame : (call_kind -> __ -> state_pc + -> state Errors.res); + setup_call : (Nat.nat -> __ -> __ -> + state -> state Errors.res); + fetch_external_args : (AST.external_function + -> state -> __ -> + Values.val0 + List.list + Errors.res); + set_result : (Values.val0 List.list -> __ + -> state -> state + Errors.res); + call_args_for_main : __; + call_dest_for_main : __; + read_result : (AST.ident List.list -> 'f + AST.fundef + Globalenvs.genv_t -> __ -> + state -> ByteValues.beval + List.list Errors.res); + eval_ext_seq : (AST.ident List.list -> 'f + genv_gen -> __ -> + AST.ident -> state -> + state Errors.res); + pop_frame : (AST.ident List.list -> 'f + genv_gen -> AST.ident -> __ + -> state -> (state, + ByteValues.program_counter) + Types.prod Errors.res) } + +val sem_unserialized_params_rect_Type4 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> 'a2) -> 'a1 + sem_unserialized_params -> 'a2 + +val sem_unserialized_params_rect_Type5 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> 'a2) -> 'a1 + sem_unserialized_params -> 'a2 + +val sem_unserialized_params_rect_Type3 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> 'a2) -> 'a1 + sem_unserialized_params -> 'a2 + +val sem_unserialized_params_rect_Type2 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> 'a2) -> 'a1 + sem_unserialized_params -> 'a2 + +val sem_unserialized_params_rect_Type1 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> 'a2) -> 'a1 + sem_unserialized_params -> 'a2 + +val sem_unserialized_params_rect_Type0 : + Joint.unserialized_params -> (sem_state_params -> (__ -> ByteValues.beval + -> __ -> __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> + __ Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> ByteValues.beval -> __ -> __ + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> + ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) + -> (__ -> __ -> __ Errors.res) -> (call_kind -> __ -> state_pc -> state + Errors.res) -> (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> 'a2) -> 'a1 + sem_unserialized_params -> 'a2 + +val st_pars : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + sem_state_params + +val acca_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res + +val acca_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val acca_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val accb_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res + +val accb_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val accb_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val dpl_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res + +val dpl_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val dpl_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val dph_store_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> __ -> __ Errors.res + +val dph_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val dph_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val snd_arg_retrieve_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> + ByteValues.beval Errors.res + +val pair_reg_move_ : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> __ -> __ + Errors.res + +val save_frame : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> call_kind -> __ + -> state_pc -> state Errors.res + +val setup_call : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> Nat.nat -> __ + -> __ -> state -> state Errors.res + +val fetch_external_args : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + AST.external_function -> state -> __ -> Values.val0 List.list Errors.res + +val set_result : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> Values.val0 + List.list -> __ -> state -> state Errors.res + +val call_args_for_main : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ + +val call_dest_for_main : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ + +val read_result : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> AST.ident + List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state -> + ByteValues.beval List.list Errors.res + +val eval_ext_seq : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> AST.ident + List.list -> 'a1 genv_gen -> __ -> AST.ident -> state -> state Errors.res + +val pop_frame : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res + +val sem_unserialized_params_inv_rect_Type4 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> __ + Errors.res) -> (call_kind -> __ -> state_pc -> state Errors.res) -> + (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> __ -> 'a2) -> 'a2 + +val sem_unserialized_params_inv_rect_Type3 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> __ + Errors.res) -> (call_kind -> __ -> state_pc -> state Errors.res) -> + (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> __ -> 'a2) -> 'a2 + +val sem_unserialized_params_inv_rect_Type2 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> __ + Errors.res) -> (call_kind -> __ -> state_pc -> state Errors.res) -> + (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> __ -> 'a2) -> 'a2 + +val sem_unserialized_params_inv_rect_Type1 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> __ + Errors.res) -> (call_kind -> __ -> state_pc -> state Errors.res) -> + (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> __ -> 'a2) -> 'a2 + +val sem_unserialized_params_inv_rect_Type0 : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> + (sem_state_params -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ + -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> ByteValues.beval -> __ -> __ Errors.res) -> (__ -> __ + -> ByteValues.beval Errors.res) -> (__ -> __ -> ByteValues.beval + Errors.res) -> (__ -> __ -> ByteValues.beval Errors.res) -> (__ -> __ -> __ + Errors.res) -> (call_kind -> __ -> state_pc -> state Errors.res) -> + (Nat.nat -> __ -> __ -> state -> state Errors.res) -> + (AST.external_function -> state -> __ -> Values.val0 List.list Errors.res) + -> (Values.val0 List.list -> __ -> state -> state Errors.res) -> __ -> __ + -> (AST.ident List.list -> 'a1 AST.fundef Globalenvs.genv_t -> __ -> state + -> ByteValues.beval List.list Errors.res) -> (AST.ident List.list -> 'a1 + genv_gen -> __ -> AST.ident -> state -> state Errors.res) -> (AST.ident + List.list -> 'a1 genv_gen -> AST.ident -> __ -> state -> (state, + ByteValues.program_counter) Types.prod Errors.res) -> __ -> 'a2) -> 'a2 + +val sem_unserialized_params_jmdiscr : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> 'a1 + sem_unserialized_params -> __ + +val helper_def_retrieve : + (Joint.unserialized_params -> __ -> __ sem_unserialized_params -> __ -> 'a1 + -> ByteValues.beval Errors.res) -> Joint.unserialized_params -> 'a2 + sem_unserialized_params -> state -> 'a1 -> ByteValues.beval Errors.res + +val helper_def_store : + (Joint.unserialized_params -> __ -> __ sem_unserialized_params -> 'a1 -> + ByteValues.beval -> __ -> __ Errors.res) -> Joint.unserialized_params -> + 'a2 sem_unserialized_params -> 'a1 -> ByteValues.beval -> state -> state + Errors.res + +val acca_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val acca_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res + +val acca_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val accb_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res + +val accb_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val accb_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val dpl_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res + +val dpl_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val dpl_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val dph_store : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> __ -> + ByteValues.beval -> state -> state Errors.res + +val dph_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val dph_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val snd_arg_retrieve : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + ByteValues.beval Errors.res + +val pair_reg_move : + Joint.unserialized_params -> 'a1 sem_unserialized_params -> state -> __ -> + __ + +val push : sem_state_params -> state -> ByteValues.beval -> state Errors.res + +val pop : + sem_state_params -> state -> (ByteValues.beval, state) Types.prod + Errors.res + +val push_ra : + sem_state_params -> state -> ByteValues.program_counter -> state Errors.res + +val pop_ra : + sem_state_params -> state -> (state, ByteValues.program_counter) Types.prod + Errors.res + +type serialized_params = { spp : Joint.params; + msu_pars : Joint.joint_closed_internal_function + sem_unserialized_params; + offset_of_point : (__ -> Positive.pos); + point_of_offset : (Positive.pos -> __) } + +val serialized_params_rect_Type4 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> 'a1) -> serialized_params -> 'a1 + +val serialized_params_rect_Type5 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> 'a1) -> serialized_params -> 'a1 + +val serialized_params_rect_Type3 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> 'a1) -> serialized_params -> 'a1 + +val serialized_params_rect_Type2 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> 'a1) -> serialized_params -> 'a1 + +val serialized_params_rect_Type1 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> 'a1) -> serialized_params -> 'a1 + +val serialized_params_rect_Type0 : + (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> 'a1) -> serialized_params -> 'a1 + +val spp : serialized_params -> Joint.params + +val msu_pars : + serialized_params -> Joint.joint_closed_internal_function + sem_unserialized_params + +val offset_of_point : serialized_params -> __ -> Positive.pos + +val point_of_offset : serialized_params -> Positive.pos -> __ + +val serialized_params_inv_rect_Type4 : + serialized_params -> (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> __ -> 'a1) -> 'a1 + +val serialized_params_inv_rect_Type3 : + serialized_params -> (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> __ -> 'a1) -> 'a1 + +val serialized_params_inv_rect_Type2 : + serialized_params -> (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> __ -> 'a1) -> 'a1 + +val serialized_params_inv_rect_Type1 : + serialized_params -> (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> __ -> 'a1) -> 'a1 + +val serialized_params_inv_rect_Type0 : + serialized_params -> (Joint.params -> Joint.joint_closed_internal_function + sem_unserialized_params -> (__ -> Positive.pos) -> (Positive.pos -> __) -> + __ -> __ -> __ -> 'a1) -> 'a1 + +val serialized_params_jmdiscr : serialized_params -> serialized_params -> __ + +val spp__o__stmt_pars : serialized_params -> Joint.stmt_params + +val spp__o__stmt_pars__o__uns_pars : serialized_params -> Joint.uns_params + +val spp__o__stmt_pars__o__uns_pars__o__u_pars : + serialized_params -> Joint.unserialized_params + +val msu_pars__o__st_pars : serialized_params -> sem_state_params + +type sem_params = { spp' : serialized_params; + pre_main_generator : (Joint.joint_program -> + Joint.joint_closed_internal_function) } + +val sem_params_rect_Type4 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 + +val sem_params_rect_Type5 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 + +val sem_params_rect_Type3 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 + +val sem_params_rect_Type2 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 + +val sem_params_rect_Type1 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 + +val sem_params_rect_Type0 : + (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> 'a1) -> sem_params -> 'a1 + +val spp' : sem_params -> serialized_params + +val pre_main_generator : + sem_params -> Joint.joint_program -> Joint.joint_closed_internal_function + +val sem_params_inv_rect_Type4 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_params_inv_rect_Type3 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_params_inv_rect_Type2 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_params_inv_rect_Type1 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_params_inv_rect_Type0 : + sem_params -> (serialized_params -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_params_jmdiscr : sem_params -> sem_params -> __ + +val spp'__o__msu_pars : + sem_params -> Joint.joint_closed_internal_function sem_unserialized_params + +val spp'__o__msu_pars__o__st_pars : sem_params -> sem_state_params + +val spp'__o__spp : sem_params -> Joint.params + +val spp'__o__spp__o__stmt_pars : sem_params -> Joint.stmt_params + +val spp'__o__spp__o__stmt_pars__o__uns_pars : sem_params -> Joint.uns_params + +val spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + sem_params -> Joint.unserialized_params + +val pc_of_point : + sem_params -> Pointers.block Types.sig0 -> __ -> ByteValues.program_counter + +val point_of_pc : sem_params -> ByteValues.program_counter -> __ + +val fetch_statement : + sem_params -> AST.ident List.list -> genv -> ByteValues.program_counter -> + ((AST.ident, Joint.joint_closed_internal_function) Types.prod, + Joint.joint_statement) Types.prod Errors.res + +val pc_of_label : + sem_params -> AST.ident List.list -> genv -> Pointers.block Types.sig0 -> + Graphs.label -> ByteValues.program_counter Errors.res + +val succ_pc : + sem_params -> ByteValues.program_counter -> __ -> + ByteValues.program_counter + +val goto : + sem_params -> AST.ident List.list -> genv -> Graphs.label -> state_pc -> + state_pc Errors.res + +val next : sem_params -> __ -> state_pc -> state_pc + +val next_of_call_pc : + sem_params -> AST.ident List.list -> genv -> ByteValues.program_counter -> + __ Errors.res + +val eval_seq_no_pc : + sem_params -> AST.ident List.list -> genv -> AST.ident -> Joint.joint_seq + -> state -> state Errors.res + +val block_of_call : + sem_params -> AST.ident List.list -> genv -> (PreIdentifiers.identifier, + (__, __) Types.prod) Types.sum -> state -> __ + +val eval_external_call : + sem_params -> AST.external_function -> __ -> __ -> state -> __ + +val increment_stack_usage : sem_state_params -> Nat.nat -> state -> state + +val decrement_stack_usage : sem_state_params -> Nat.nat -> state -> state + +val eval_internal_call : + sem_params -> AST.ident List.list -> genv -> PreIdentifiers.identifier -> + Joint.joint_internal_function -> __ -> state -> __ + +val is_inl : ('a1, 'a2) Types.sum -> Bool.bool + +val eval_call : + sem_params -> AST.ident List.list -> genv -> (PreIdentifiers.identifier, + (__, __) Types.prod) Types.sum -> __ -> __ -> __ -> state_pc -> __ + +val eval_statement_no_pc : + sem_params -> AST.ident List.list -> genv -> AST.ident -> + Joint.joint_statement -> state -> state Errors.res + +val eval_return : + sem_params -> AST.ident List.list -> genv -> PreIdentifiers.identifier -> + __ -> state -> __ + +val eval_tailcall : + sem_params -> AST.ident List.list -> genv -> (PreIdentifiers.identifier, + (__, __) Types.prod) Types.sum -> __ -> PreIdentifiers.identifier -> __ -> + state_pc -> __ + +val eval_statement_advance : + sem_params -> AST.ident List.list -> genv -> AST.ident -> + Joint.joint_closed_internal_function -> Joint.joint_statement -> state_pc + -> (IO.io_out, IO.io_in, state_pc) IOMonad.iO + +val eval_state : + sem_params -> AST.ident List.list -> genv -> state_pc -> (IO.io_out, + IO.io_in, state_pc) IOMonad.iO + diff --git a/extracted/lIN.ml b/extracted/lIN.ml new file mode 100644 index 0000000..6bb3a57 --- /dev/null +++ b/extracted/lIN.ml @@ -0,0 +1,147 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +(** val lIN : Joint.lin_params **) +let lIN = + Joint_LTL_LIN.lTL_LIN + +type lin_program = Joint.joint_program + +(** val lIN_premain : lin_program -> Joint.joint_closed_internal_function **) +let lIN_premain p = + let l3 = Positive.P1 Positive.One in + let code = List.Cons ({ Types.fst = Types.None; Types.snd = + (Joint.Sequential ((Joint.COST_LABEL p.Joint.init_cost_label), + (Obj.magic Types.It))) }, (List.Cons ({ Types.fst = Types.None; + Types.snd = (Joint.Sequential ((Joint.CALL ((Types.Inl + p.Joint.joint_prog.AST.prog_main), (Obj.magic Nat.O), + (Obj.magic Types.It))), (Obj.magic Types.It))) }, (List.Cons + ({ Types.fst = (Types.Some l3); Types.snd = (Joint.Final (Joint.GOTO + l3)) }, List.Nil))))) + in + { Joint.joint_if_luniverse = (Positive.P0 (Positive.P0 Positive.One)); + Joint.joint_if_runiverse = Positive.One; Joint.joint_if_result = + (Obj.magic Types.It); Joint.joint_if_params = (Obj.magic Types.It); + Joint.joint_if_stacksize = Nat.O; Joint.joint_if_local_stacksize = Nat.O; + Joint.joint_if_code = (Obj.magic code); Joint.joint_if_entry = + (Obj.magic Nat.O) } + diff --git a/extracted/lIN.mli b/extracted/lIN.mli new file mode 100644 index 0000000..605f207 --- /dev/null +++ b/extracted/lIN.mli @@ -0,0 +1,128 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +val lIN : Joint.lin_params + +type lin_program = Joint.joint_program + +val lIN_premain : lin_program -> Joint.joint_closed_internal_function + diff --git a/extracted/lINToASM.ml b/extracted/lINToASM.ml new file mode 100644 index 0000000..770789a --- /dev/null +++ b/extracted/lINToASM.ml @@ -0,0 +1,1447 @@ +open Preamble + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open BitVectorTrie + +open BitVectorTrieSet + +open State + +open String + +open Exp + +open Arithmetic + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Sets + +open Listb + +open Graphs + +open I8051 + +open Order + +open Registers + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open LIN + +type aSM_universe = { id_univ : Identifiers.universe; + current_funct : AST.ident; + ident_map : ASM.identifier Identifiers.identifier_map; + label_map : ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map; + fresh_cost_label : Positive.pos } + +(** val aSM_universe_rect_Type4 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 **) +let rec aSM_universe_rect_Type4 h_mk_ASM_universe x_21483 = + let { id_univ = id_univ0; current_funct = current_funct0; ident_map = + ident_map0; label_map = label_map0; fresh_cost_label = + fresh_cost_label0 } = x_21483 + in + h_mk_ASM_universe id_univ0 current_funct0 ident_map0 label_map0 + fresh_cost_label0 + +(** val aSM_universe_rect_Type5 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 **) +let rec aSM_universe_rect_Type5 h_mk_ASM_universe x_21485 = + let { id_univ = id_univ0; current_funct = current_funct0; ident_map = + ident_map0; label_map = label_map0; fresh_cost_label = + fresh_cost_label0 } = x_21485 + in + h_mk_ASM_universe id_univ0 current_funct0 ident_map0 label_map0 + fresh_cost_label0 + +(** val aSM_universe_rect_Type3 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 **) +let rec aSM_universe_rect_Type3 h_mk_ASM_universe x_21487 = + let { id_univ = id_univ0; current_funct = current_funct0; ident_map = + ident_map0; label_map = label_map0; fresh_cost_label = + fresh_cost_label0 } = x_21487 + in + h_mk_ASM_universe id_univ0 current_funct0 ident_map0 label_map0 + fresh_cost_label0 + +(** val aSM_universe_rect_Type2 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 **) +let rec aSM_universe_rect_Type2 h_mk_ASM_universe x_21489 = + let { id_univ = id_univ0; current_funct = current_funct0; ident_map = + ident_map0; label_map = label_map0; fresh_cost_label = + fresh_cost_label0 } = x_21489 + in + h_mk_ASM_universe id_univ0 current_funct0 ident_map0 label_map0 + fresh_cost_label0 + +(** val aSM_universe_rect_Type1 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 **) +let rec aSM_universe_rect_Type1 h_mk_ASM_universe x_21491 = + let { id_univ = id_univ0; current_funct = current_funct0; ident_map = + ident_map0; label_map = label_map0; fresh_cost_label = + fresh_cost_label0 } = x_21491 + in + h_mk_ASM_universe id_univ0 current_funct0 ident_map0 label_map0 + fresh_cost_label0 + +(** val aSM_universe_rect_Type0 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 **) +let rec aSM_universe_rect_Type0 h_mk_ASM_universe x_21493 = + let { id_univ = id_univ0; current_funct = current_funct0; ident_map = + ident_map0; label_map = label_map0; fresh_cost_label = + fresh_cost_label0 } = x_21493 + in + h_mk_ASM_universe id_univ0 current_funct0 ident_map0 label_map0 + fresh_cost_label0 + +(** val id_univ : aSM_universe -> Identifiers.universe **) +let rec id_univ xxx = + xxx.id_univ + +(** val current_funct : aSM_universe -> AST.ident **) +let rec current_funct xxx = + xxx.current_funct + +(** val ident_map : + aSM_universe -> ASM.identifier Identifiers.identifier_map **) +let rec ident_map xxx = + xxx.ident_map + +(** val label_map : + aSM_universe -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map **) +let rec label_map xxx = + xxx.label_map + +(** val fresh_cost_label : aSM_universe -> Positive.pos **) +let rec fresh_cost_label xxx = + xxx.fresh_cost_label + +(** val aSM_universe_inv_rect_Type4 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 **) +let aSM_universe_inv_rect_Type4 hterm h1 = + let hcut = aSM_universe_rect_Type4 h1 hterm in hcut __ + +(** val aSM_universe_inv_rect_Type3 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 **) +let aSM_universe_inv_rect_Type3 hterm h1 = + let hcut = aSM_universe_rect_Type3 h1 hterm in hcut __ + +(** val aSM_universe_inv_rect_Type2 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 **) +let aSM_universe_inv_rect_Type2 hterm h1 = + let hcut = aSM_universe_rect_Type2 h1 hterm in hcut __ + +(** val aSM_universe_inv_rect_Type1 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 **) +let aSM_universe_inv_rect_Type1 hterm h1 = + let hcut = aSM_universe_rect_Type1 h1 hterm in hcut __ + +(** val aSM_universe_inv_rect_Type0 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 **) +let aSM_universe_inv_rect_Type0 hterm h1 = + let hcut = aSM_universe_rect_Type0 h1 hterm in hcut __ + +(** val aSM_universe_discr : aSM_universe -> aSM_universe -> __ **) +let aSM_universe_discr x y = + Logic.eq_rect_Type2 x + (let { id_univ = a0; current_funct = a1; ident_map = a2; label_map = a3; + fresh_cost_label = a4 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val aSM_universe_jmdiscr : aSM_universe -> aSM_universe -> __ **) +let aSM_universe_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { id_univ = a0; current_funct = a1; ident_map = a2; label_map = a3; + fresh_cost_label = a4 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val report_cost : + CostLabel.costlabel -> Types.unit0 Monad.smax_def__o__monad **) +let report_cost cl = + Obj.magic (fun u -> + let clw = Identifiers.word_of_identifier PreIdentifiers.CostTag cl in + (match Positive.leb u.fresh_cost_label clw with + | Bool.True -> + { Types.fst = { id_univ = u.id_univ; current_funct = u.current_funct; + ident_map = u.ident_map; label_map = u.label_map; fresh_cost_label = + (Positive.succ clw) }; Types.snd = Types.It } + | Bool.False -> { Types.fst = u; Types.snd = Types.It })) + +(** val identifier_of_label : + Graphs.label -> ASM.identifier Monad.smax_def__o__monad **) +let identifier_of_label l = + Obj.magic (fun u -> + let current = u.current_funct in + let lmap = + Identifiers.lookup_def PreIdentifiers.SymbolTag u.label_map current + (Identifiers.empty_map PreIdentifiers.LabelTag) + in + let { Types.fst = eta28616; Types.snd = lmap0 } = + match Identifiers.lookup PreIdentifiers.LabelTag lmap l with + | Types.None -> + let { Types.fst = id; Types.snd = univ } = + Identifiers.fresh PreIdentifiers.ASMTag u.id_univ + in + { Types.fst = { Types.fst = id; Types.snd = univ }; Types.snd = + (Identifiers.add PreIdentifiers.LabelTag lmap l id) } + | Types.Some id -> + { Types.fst = { Types.fst = id; Types.snd = u.id_univ }; Types.snd = + lmap } + in + let { Types.fst = id; Types.snd = univ } = eta28616 in + { Types.fst = { id_univ = univ; current_funct = current; ident_map = + u.ident_map; label_map = + (Identifiers.add PreIdentifiers.SymbolTag u.label_map current lmap0); + fresh_cost_label = u.fresh_cost_label }; Types.snd = id }) + +(** val identifier_of_ident : + AST.ident -> ASM.identifier Monad.smax_def__o__monad **) +let identifier_of_ident i = + Obj.magic (fun u -> + let imap = u.ident_map in + let res = + match Identifiers.lookup PreIdentifiers.SymbolTag imap i with + | Types.None -> + let { Types.fst = id; Types.snd = univ } = + Identifiers.fresh PreIdentifiers.ASMTag u.id_univ + in + { Types.fst = { Types.fst = id; Types.snd = univ }; Types.snd = + (Identifiers.add PreIdentifiers.SymbolTag imap i id) } + | Types.Some id -> + { Types.fst = { Types.fst = id; Types.snd = u.id_univ }; Types.snd = + imap } + in + let id = res.Types.fst.Types.fst in + let univ = res.Types.fst.Types.snd in + let imap0 = res.Types.snd in + { Types.fst = { id_univ = univ; current_funct = u.current_funct; + ident_map = imap0; label_map = u.label_map; fresh_cost_label = + u.fresh_cost_label }; Types.snd = id }) + +(** val new_ASM_universe : Joint.joint_program -> aSM_universe **) +let new_ASM_universe p = + { id_univ = Positive.One; current_funct = Positive.One; ident_map = + (Identifiers.empty_map PreIdentifiers.SymbolTag); label_map = + (Identifiers.empty_map PreIdentifiers.SymbolTag); fresh_cost_label = + Positive.One } + +(** val start_funct_translation : + AST.ident List.list -> AST.ident List.list -> (AST.ident, + Joint.joint_function) Types.prod -> Types.unit0 Monad.smax_def__o__monad **) +let start_funct_translation g functs id_f = + Obj.magic (fun u -> { Types.fst = { id_univ = u.id_univ; current_funct = + id_f.Types.fst; ident_map = u.ident_map; label_map = u.label_map; + fresh_cost_label = u.fresh_cost_label }; Types.snd = Types.It }) + +(** val aSM_fresh : ASM.identifier Monad.smax_def__o__monad **) +let aSM_fresh = + Obj.magic (fun u -> + let { Types.fst = id; Types.snd = univ } = + Identifiers.fresh PreIdentifiers.ASMTag u.id_univ + in + { Types.fst = { id_univ = univ; current_funct = u.current_funct; + ident_map = u.ident_map; label_map = u.label_map; fresh_cost_label = + u.fresh_cost_label }; Types.snd = id }) + +(** val register_address : I8051.register -> ASM.subaddressing_mode **) +let register_address r = + (match r with + | I8051.Register00 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty))))))) + | I8051.Register01 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty))))))) + | I8051.Register02 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty))))))) + | I8051.Register03 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty))))))) + | I8051.Register04 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty))))))) + | I8051.Register05 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty))))))) + | I8051.Register06 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.False, Vector.VEmpty))))))) + | I8051.Register07 -> + (fun _ -> ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.True, + (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons (Nat.O, + Bool.True, Vector.VEmpty))))))) + | I8051.Register10 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register11 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register12 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register13 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register14 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register15 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register16 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register17 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register20 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register21 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register22 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register23 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register24 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register25 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register26 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register27 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register30 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register31 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register32 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register33 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register34 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register35 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register36 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.Register37 -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r))) + | I8051.RegisterA -> (fun _ -> ASM.ACC_A) + | I8051.RegisterB -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + | I8051.RegisterDPL -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + | I8051.RegisterDPH -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + | I8051.RegisterCarry -> + (fun _ -> ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (I8051.nat_of_register r)))) __ + +(** val vector_cast : + Nat.nat -> Nat.nat -> 'a1 -> 'a1 Vector.vector -> 'a1 Vector.vector **) +let vector_cast n m dflt v = + Util.if_then_else_safe (Nat.leb n m) (fun _ -> + Vector.append (Nat.minus m n) n (Vector.replicate (Nat.minus m n) dflt) v) + (fun _ -> (Vector.vsplit (Nat.minus n m) m v).Types.snd) + +(** val arg_address : Joint.hdw_argument -> ASM.subaddressing_mode **) +let arg_address = function +| Joint.Reg r -> + let x = + ASM.subaddressing_modeel__o__mk_subaddressing_mode (Nat.S (Nat.S Nat.O)) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Acc_a, (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons + (Nat.O, ASM.Registr, Vector.VEmpty)))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ASM.Direct, (Vector.VCons ((Nat.S Nat.O), ASM.Registr, (Vector.VCons + (Nat.O, ASM.Data, Vector.VEmpty)))))))) (register_address r) + in + x +| Joint.Imm v -> let x = ASM.DATA v in x + +type lin_statement = Joint.joint_statement LabelledObjects.labelled_obj + +(** val data_of_int : BitVector.byte -> ASM.addressing_mode **) +let data_of_int bv = + ASM.DATA bv + +(** val data16_of_int : Nat.nat -> ASM.addressing_mode **) +let data16_of_int bv = + ASM.DATA16 + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) bv) + +(** val accumulator_address : ASM.addressing_mode **) +let accumulator_address = + ASM.DIRECT + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + +(** val asm_other_bit : ASM.addressing_mode **) +let asm_other_bit = + ASM.BIT_ADDR Joint.zero_byte + +(** val one_word : BitVector.word **) +let one_word = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))) + (Nat.S Nat.O) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) + (Vector.VCons (Nat.O, Bool.True, Vector.VEmpty)) + +(** val translate_statements : + AST.ident List.list -> Joint.joint_statement -> ASM.pseudo_instruction + Monad.smax_def__o__monad **) +let translate_statements globals = function +| Joint.Sequential (instr, x) -> + (match instr with + | Joint.COST_LABEL lbl -> + Monad.m_bind0 (Monad.smax_def State.state_monad) (report_cost lbl) + (fun x0 -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Cost lbl)) + | Joint.CALL (f, x0, x1) -> + (match f with + | Types.Inl id -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_ident id) (fun id' -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Call + (ASM.toASM_ident PreIdentifiers.ASMTag id'))) + | Types.Inr x2 -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.JMP ASM.ACC_DPTR))) + | Joint.COND (x0, lbl) -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_label lbl) (fun l -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.JNZ l))) + | Joint.Step_seq instr' -> + (match instr' with + | Joint.COMMENT comment -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Comment + comment) + | Joint.MOVE regs -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (match Obj.magic regs with + | Joint_LTL_LIN.From_acc (reg, x0) -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons + (Nat.O, ASM.Registr, Vector.VEmpty)))))) + (register_address reg) with + | ASM.DIRECT d -> + (fun _ -> ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inr { Types.fst = (ASM.DIRECT d); + Types.snd = ASM.ACC_A })))))) + | ASM.INDIRECT x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x1 -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.REGISTER r); Types.snd = ASM.ACC_A }))))))) + | ASM.ACC_A -> (fun _ -> ASM.Instruction ASM.NOP) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x1 -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x1 -> (fun _ -> assert false (* absurd case *))) + __ + | Joint_LTL_LIN.To_acc (x0, reg) -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons + (Nat.O, ASM.Registr, Vector.VEmpty)))))) + (register_address reg) with + | ASM.DIRECT d -> + (fun _ -> ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inl (Types.Inl { Types.fst = ASM.ACC_A; + Types.snd = (ASM.DIRECT d) }))))))) + | ASM.INDIRECT x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x1 -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inl (Types.Inl { Types.fst = ASM.ACC_A; + Types.snd = (ASM.REGISTER r) }))))))) + | ASM.ACC_A -> (fun _ -> ASM.Instruction ASM.NOP) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x1 -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x1 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x1 -> (fun _ -> assert false (* absurd case *))) + __ + | Joint_LTL_LIN.Int_to_reg (reg, b) -> + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, + (Vector.VCons ((Nat.S Nat.O), ASM.Direct, (Vector.VCons + (Nat.O, ASM.Registr, Vector.VEmpty)))))) + (register_address reg) with + | ASM.DIRECT d -> + (fun _ -> ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inr { Types.fst = (ASM.DIRECT d); + Types.snd = (ASM.DATA b) })))))) + | ASM.INDIRECT x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.REGISTER r); Types.snd = (ASM.DATA b) }))))))) + | ASM.ACC_A -> + (fun _ -> + match BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) b with + | Bool.True -> ASM.Instruction (ASM.CLR ASM.ACC_A) + | Bool.False -> + ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl (Types.Inl + (Types.Inl (Types.Inl { Types.fst = ASM.ACC_A; + Types.snd = (ASM.DATA b) }))))))) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x0 -> + (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x0 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x0 -> (fun _ -> assert false (* absurd case *))) + __ + | Joint_LTL_LIN.Int_to_acc (x0, b) -> + (match BitVector.eq_bv (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) b with + | Bool.True -> ASM.Instruction (ASM.CLR ASM.ACC_A) + | Bool.False -> + ASM.Instruction (ASM.MOV (Types.Inl (Types.Inl (Types.Inl + (Types.Inl (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + (ASM.DATA b) })))))))) + | Joint.POP x0 -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.POP accumulator_address)) + | Joint.PUSH x0 -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.PUSH accumulator_address)) + | Joint.ADDRESS (id, off, x0, x1) -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_ident id) (fun id0 -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Mov + ((Types.Inl ASM.DPTR), id0, off))) + | Joint.OPACCS (accs, x0, x1, x2, x3) -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (match accs with + | BackEndOps.Mul -> + ASM.Instruction (ASM.MUL (ASM.ACC_A, ASM.ACC_B)) + | BackEndOps.DivuModu -> + ASM.Instruction (ASM.DIV (ASM.ACC_A, ASM.ACC_B))) + | Joint.OP1 (op1, x0, x1) -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (match op1 with + | BackEndOps.Cmpl -> ASM.Instruction (ASM.CPL ASM.ACC_A) + | BackEndOps.Inc -> ASM.Instruction (ASM.INC ASM.ACC_A) + | BackEndOps.Rl -> ASM.Instruction (ASM.RL ASM.ACC_A)) + | Joint.OP2 (op2, x0, x1, reg) -> + Monad.m_return0 (Monad.smax_def State.state_monad) + ((match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S Nat.O))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), ASM.Direct, + (Vector.VCons ((Nat.S Nat.O), ASM.Registr, (Vector.VCons + (Nat.O, ASM.Data, Vector.VEmpty)))))))) + (arg_address (Obj.magic reg)) with + | ASM.DIRECT d -> + (fun _ -> + match op2 with + | BackEndOps.Add -> + ASM.Instruction (ASM.ADD (ASM.ACC_A, (ASM.DIRECT d))) + | BackEndOps.Addc -> + ASM.Instruction (ASM.ADDC (ASM.ACC_A, (ASM.DIRECT d))) + | BackEndOps.Sub -> + ASM.Instruction (ASM.SUBB (ASM.ACC_A, (ASM.DIRECT d))) + | BackEndOps.And -> + ASM.Instruction (ASM.ANL (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DIRECT d) }))) + | BackEndOps.Or -> + ASM.Instruction (ASM.ORL (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DIRECT d) }))) + | BackEndOps.Xor -> + ASM.Instruction (ASM.XRL (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = (ASM.DIRECT d) }))) + | ASM.INDIRECT x2 -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x2 -> + (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> + match op2 with + | BackEndOps.Add -> + ASM.Instruction (ASM.ADD (ASM.ACC_A, (ASM.REGISTER r))) + | BackEndOps.Addc -> + ASM.Instruction (ASM.ADDC (ASM.ACC_A, (ASM.REGISTER r))) + | BackEndOps.Sub -> + ASM.Instruction (ASM.SUBB (ASM.ACC_A, (ASM.REGISTER r))) + | BackEndOps.And -> + ASM.Instruction (ASM.ANL (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.REGISTER + r) }))) + | BackEndOps.Or -> + ASM.Instruction (ASM.ORL (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.REGISTER + r) }))) + | BackEndOps.Xor -> + ASM.Instruction (ASM.XRL (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = (ASM.REGISTER r) }))) + | ASM.ACC_A -> + (fun _ -> + match op2 with + | BackEndOps.Add -> + ASM.Instruction (ASM.ADD (ASM.ACC_A, accumulator_address)) + | BackEndOps.Addc -> + ASM.Instruction (ASM.ADDC (ASM.ACC_A, accumulator_address)) + | BackEndOps.Sub -> + ASM.Instruction (ASM.SUBB (ASM.ACC_A, accumulator_address)) + | BackEndOps.And -> ASM.Instruction ASM.NOP + | BackEndOps.Or -> ASM.Instruction ASM.NOP + | BackEndOps.Xor -> ASM.Instruction (ASM.CLR ASM.ACC_A)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA b -> + (fun _ -> + match op2 with + | BackEndOps.Add -> + ASM.Instruction (ASM.ADD (ASM.ACC_A, (ASM.DATA b))) + | BackEndOps.Addc -> + ASM.Instruction (ASM.ADDC (ASM.ACC_A, (ASM.DATA b))) + | BackEndOps.Sub -> + ASM.Instruction (ASM.SUBB (ASM.ACC_A, (ASM.DATA b))) + | BackEndOps.And -> + ASM.Instruction (ASM.ANL (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DATA b) }))) + | BackEndOps.Or -> + ASM.Instruction (ASM.ORL (Types.Inl (Types.Inl + { Types.fst = ASM.ACC_A; Types.snd = (ASM.DATA b) }))) + | BackEndOps.Xor -> + ASM.Instruction (ASM.XRL (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = (ASM.DATA b) }))) + | ASM.DATA16 x2 -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x2 -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x2 -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x2 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x2 -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x2 -> (fun _ -> assert false (* absurd case *))) __) + | Joint.CLEAR_CARRY -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.CLR ASM.CARRY)) + | Joint.SET_CARRY -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.SETB ASM.CARRY)) + | Joint.LOAD (x0, x1, x2) -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.MOVX (Types.Inl { Types.fst = ASM.ACC_A; Types.snd = + ASM.EXT_INDIRECT_DPTR }))) + | Joint.STORE (x0, x1, x2) -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + (ASM.MOVX (Types.Inr { Types.fst = ASM.EXT_INDIRECT_DPTR; + Types.snd = ASM.ACC_A }))) + | Joint.Extension_seq ext -> + (match Obj.magic ext with + | Joint_LTL_LIN.SAVE_CARRY -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (ASM.Instruction (ASM.MOV (Types.Inr { Types.fst = + asm_other_bit; Types.snd = ASM.CARRY }))) + | Joint_LTL_LIN.RESTORE_CARRY -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (ASM.Instruction (ASM.MOV (Types.Inl (Types.Inr { Types.fst = + ASM.CARRY; Types.snd = asm_other_bit })))) + | Joint_LTL_LIN.LOW_ADDRESS lbl -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_label lbl) (fun lbl' -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Mov + ((Types.Inr { Types.fst = (register_address I8051.RegisterA); + Types.snd = ASM.LOW }), lbl', one_word))) + | Joint_LTL_LIN.HIGH_ADDRESS lbl -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_label lbl) (fun lbl' -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Mov + ((Types.Inr { Types.fst = (register_address I8051.RegisterA); + Types.snd = ASM.HIGH }), lbl', one_word)))))) +| Joint.Final instr -> + (match instr with + | Joint.GOTO lbl -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_label lbl) (fun lbl' -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Jmp + (ASM.toASM_ident PreIdentifiers.ASMTag lbl'))) + | Joint.RETURN -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Instruction + ASM.RET) + | Joint.TAILCALL (x, x0) -> assert false (* absurd case *)) +| Joint.FCOND (x0, lbl_true, lbl_false) -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_label lbl_true) (fun l1 -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_label lbl_false) (fun l2 -> + Monad.m_return0 (Monad.smax_def State.state_monad) (ASM.Jnz (ASM.ACC_A, + l1, l2)))) + +(** val build_translated_statement : + AST.ident List.list -> lin_statement -> __ **) +let build_translated_statement globals statement = + Monad.m_bind0 (Monad.smax_def State.state_monad) + (translate_statements globals statement.Types.snd) (fun stmt -> + match statement.Types.fst with + | Types.None -> + Monad.m_return0 (Monad.smax_def State.state_monad) { Types.fst = + Types.None; Types.snd = stmt } + | Types.Some lbl -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_label lbl) (fun lbl' -> + Monad.m_return0 (Monad.smax_def State.state_monad) { Types.fst = + (Types.Some lbl'); Types.snd = stmt })) + +(** val translate_code : + AST.ident List.list -> lin_statement List.list -> __ **) +let translate_code globals code = + Monad.m_list_map (Monad.smax_def State.state_monad) + (build_translated_statement globals) code + +(** val translate_fun_def : + AST.ident List.list -> AST.ident List.list -> (AST.ident, + Joint.joint_function) Types.prod -> __ **) +let translate_fun_def globals functions id_def = + Monad.m_bind0 (Monad.smax_def State.state_monad) + (start_funct_translation globals functions id_def) (fun x -> + match id_def.Types.snd with + | AST.Internal int -> + let code = (Types.pi1 int).Joint.joint_if_code in + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_ident id_def.Types.fst) (fun id -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (translate_code (List.append functions globals) (Obj.magic code)) + (fun code' -> + match code' with + | List.Nil -> + Monad.m_return0 (Monad.smax_def State.state_monad) (List.Cons + ({ Types.fst = (Types.Some id); Types.snd = (ASM.Instruction + ASM.RET) }, List.Nil)) + | List.Cons (hd, tl) -> + (match hd.Types.fst with + | Types.None -> + Monad.m_return0 (Monad.smax_def State.state_monad) (List.Cons + ({ Types.fst = (Types.Some id); Types.snd = hd.Types.snd }, + tl)) + | Types.Some x0 -> + Monad.m_return0 (Monad.smax_def State.state_monad) (List.Cons + ({ Types.fst = (Types.Some id); Types.snd = (ASM.Instruction + ASM.NOP) }, (List.Cons (hd, tl))))))) + | AST.External x0 -> + Monad.m_return0 (Monad.smax_def State.state_monad) List.Nil) + +type init_mutable = { virtual_dptr : (ASM.identifier, Z.z) Types.prod; + actual_dptr : (ASM.identifier, Z.z) Types.prod; + built_code : ASM.labelled_instruction List.list + List.list; + built_preamble : (ASM.identifier, BitVector.word) + Types.prod List.list } + +(** val init_mutable_rect_Type4 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 **) +let rec init_mutable_rect_Type4 h_mk_init_mutable x_21509 = + let { virtual_dptr = virtual_dptr0; actual_dptr = actual_dptr0; + built_code = built_code0; built_preamble = built_preamble0 } = x_21509 + in + h_mk_init_mutable virtual_dptr0 actual_dptr0 built_code0 built_preamble0 + +(** val init_mutable_rect_Type5 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 **) +let rec init_mutable_rect_Type5 h_mk_init_mutable x_21511 = + let { virtual_dptr = virtual_dptr0; actual_dptr = actual_dptr0; + built_code = built_code0; built_preamble = built_preamble0 } = x_21511 + in + h_mk_init_mutable virtual_dptr0 actual_dptr0 built_code0 built_preamble0 + +(** val init_mutable_rect_Type3 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 **) +let rec init_mutable_rect_Type3 h_mk_init_mutable x_21513 = + let { virtual_dptr = virtual_dptr0; actual_dptr = actual_dptr0; + built_code = built_code0; built_preamble = built_preamble0 } = x_21513 + in + h_mk_init_mutable virtual_dptr0 actual_dptr0 built_code0 built_preamble0 + +(** val init_mutable_rect_Type2 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 **) +let rec init_mutable_rect_Type2 h_mk_init_mutable x_21515 = + let { virtual_dptr = virtual_dptr0; actual_dptr = actual_dptr0; + built_code = built_code0; built_preamble = built_preamble0 } = x_21515 + in + h_mk_init_mutable virtual_dptr0 actual_dptr0 built_code0 built_preamble0 + +(** val init_mutable_rect_Type1 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 **) +let rec init_mutable_rect_Type1 h_mk_init_mutable x_21517 = + let { virtual_dptr = virtual_dptr0; actual_dptr = actual_dptr0; + built_code = built_code0; built_preamble = built_preamble0 } = x_21517 + in + h_mk_init_mutable virtual_dptr0 actual_dptr0 built_code0 built_preamble0 + +(** val init_mutable_rect_Type0 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 **) +let rec init_mutable_rect_Type0 h_mk_init_mutable x_21519 = + let { virtual_dptr = virtual_dptr0; actual_dptr = actual_dptr0; + built_code = built_code0; built_preamble = built_preamble0 } = x_21519 + in + h_mk_init_mutable virtual_dptr0 actual_dptr0 built_code0 built_preamble0 + +(** val virtual_dptr : init_mutable -> (ASM.identifier, Z.z) Types.prod **) +let rec virtual_dptr xxx = + xxx.virtual_dptr + +(** val actual_dptr : init_mutable -> (ASM.identifier, Z.z) Types.prod **) +let rec actual_dptr xxx = + xxx.actual_dptr + +(** val built_code : + init_mutable -> ASM.labelled_instruction List.list List.list **) +let rec built_code xxx = + xxx.built_code + +(** val built_preamble : + init_mutable -> (ASM.identifier, BitVector.word) Types.prod List.list **) +let rec built_preamble xxx = + xxx.built_preamble + +(** val init_mutable_inv_rect_Type4 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, + Z.z) Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> + 'a1 **) +let init_mutable_inv_rect_Type4 hterm h1 = + let hcut = init_mutable_rect_Type4 h1 hterm in hcut __ + +(** val init_mutable_inv_rect_Type3 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, + Z.z) Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> + 'a1 **) +let init_mutable_inv_rect_Type3 hterm h1 = + let hcut = init_mutable_rect_Type3 h1 hterm in hcut __ + +(** val init_mutable_inv_rect_Type2 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, + Z.z) Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> + 'a1 **) +let init_mutable_inv_rect_Type2 hterm h1 = + let hcut = init_mutable_rect_Type2 h1 hterm in hcut __ + +(** val init_mutable_inv_rect_Type1 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, + Z.z) Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> + 'a1 **) +let init_mutable_inv_rect_Type1 hterm h1 = + let hcut = init_mutable_rect_Type1 h1 hterm in hcut __ + +(** val init_mutable_inv_rect_Type0 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, + Z.z) Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> + 'a1 **) +let init_mutable_inv_rect_Type0 hterm h1 = + let hcut = init_mutable_rect_Type0 h1 hterm in hcut __ + +(** val init_mutable_discr : init_mutable -> init_mutable -> __ **) +let init_mutable_discr x y = + Logic.eq_rect_Type2 x + (let { virtual_dptr = a0; actual_dptr = a1; built_code = a2; + built_preamble = a3 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val init_mutable_jmdiscr : init_mutable -> init_mutable -> __ **) +let init_mutable_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { virtual_dptr = a0; actual_dptr = a1; built_code = a2; + built_preamble = a3 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val store_byte_or_Identifier : + (BitVector.byte, (ASM.word_side, ASM.identifier) Types.prod) Types.sum -> + init_mutable -> init_mutable **) +let store_byte_or_Identifier by mut = + let { virtual_dptr = virt; actual_dptr = act; built_code = acc1; + built_preamble = acc2 } = mut + in + let pre = + match Identifiers.eq_identifier PreIdentifiers.ASMTag virt.Types.fst + act.Types.fst with + | Bool.True -> + let off = Z.zminus virt.Types.snd act.Types.snd in + (match Z.eqZb off Z.OZ with + | Bool.True -> List.Nil + | Bool.False -> + (match Z.eqZb off (Z.z_of_nat (Nat.S Nat.O)) with + | Bool.True -> + List.Cons ({ Types.fst = Types.None; Types.snd = (ASM.Instruction + (ASM.INC ASM.DPTR)) }, List.Nil) + | Bool.False -> + List.Cons ({ Types.fst = Types.None; Types.snd = (ASM.Mov + ((Types.Inl ASM.DPTR), virt.Types.fst, + (BitVectorZ.bitvector_of_Z (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) virt.Types.snd))) }, + List.Nil))) + | Bool.False -> + List.Cons ({ Types.fst = Types.None; Types.snd = (ASM.Mov ((Types.Inl + ASM.DPTR), virt.Types.fst, + (BitVectorZ.bitvector_of_Z (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) virt.Types.snd))) }, List.Nil) + in + let post = + match by with + | Types.Inl by0 -> + { Types.fst = Types.None; Types.snd = (ASM.Instruction (ASM.MOV + (Types.Inl (Types.Inl (Types.Inl (Types.Inl (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = (ASM.DATA by0) }))))))) } + | Types.Inr si_id -> + { Types.fst = Types.None; Types.snd = (ASM.Mov ((Types.Inr + { Types.fst = ASM.ACC_A; Types.snd = si_id.Types.fst }), + si_id.Types.snd, + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))) } + in + { virtual_dptr = { Types.fst = virt.Types.fst; Types.snd = + (Z.zsucc virt.Types.snd) }; actual_dptr = virt; built_code = (List.Cons + ((List.append pre (List.Cons (post, (List.Cons ({ Types.fst = Types.None; + Types.snd = (ASM.Instruction (ASM.MOVX (Types.Inr { Types.fst = + ASM.EXT_INDIRECT_DPTR; Types.snd = ASM.ACC_A }))) }, List.Nil))))), + acc1)); built_preamble = acc2 } + +(** val do_store_init_data : + init_mutable Monad.smax_def__o__monad -> AST.init_data -> init_mutable + Monad.smax_def__o__monad **) +let do_store_init_data m_mut data = + Monad.m_bind0 (Monad.smax_def State.state_monad) m_mut (fun mut -> + let store_byte = fun by -> store_byte_or_Identifier (Types.Inl by) in + let store_Identifier = fun side id -> + store_byte_or_Identifier (Types.Inr { Types.fst = side; Types.snd = + id }) + in + (match data with + | AST.Init_int8 n -> + Monad.m_return0 (Monad.smax_def State.state_monad) (store_byte n mut) + | AST.Init_int16 n -> + let { Types.fst = by0; Types.snd = by1 } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) n + in + Monad.m_return0 (Monad.smax_def State.state_monad) + (store_byte by1 (store_byte by0 mut)) + | AST.Init_int32 n -> + let { Types.fst = by0; Types.snd = n0 } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))) n + in + let { Types.fst = by1; Types.snd = n1 } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) n0 + in + let { Types.fst = by2; Types.snd = by3 } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) n1 + in + Monad.m_return0 (Monad.smax_def State.state_monad) + (store_byte by3 + (store_byte by2 (store_byte by1 (store_byte by0 mut)))) + | AST.Init_space n -> + let { Types.fst = virt_id; Types.snd = virt_off } = mut.virtual_dptr + in + Monad.m_return0 (Monad.smax_def State.state_monad) { virtual_dptr = + { Types.fst = virt_id; Types.snd = + (Z.zplus (Z.z_of_nat n) virt_off) }; actual_dptr = mut.actual_dptr; + built_code = mut.built_code; built_preamble = mut.built_preamble } + | AST.Init_null -> + let z = + BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + in + Monad.m_return0 (Monad.smax_def State.state_monad) + (store_byte z (store_byte z mut)) + | AST.Init_addrof (symb, ofs) -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_ident symb) (fun id -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (store_Identifier ASM.HIGH id (store_Identifier ASM.LOW id mut))))) + +(** val do_store_global : + init_mutable Monad.smax_def__o__monad -> ((AST.ident, AST.region) + Types.prod, AST.init_data List.list) Types.prod -> init_mutable + Monad.smax_def__o__monad **) +let do_store_global m_mut id_reg_data = + Monad.m_bind0 (Monad.smax_def State.state_monad) m_mut (fun mut -> + let { Types.fst = eta28633; Types.snd = data } = id_reg_data in + let { Types.fst = id; Types.snd = reg } = eta28633 in + Monad.m_bind0 (Monad.smax_def State.state_monad) (identifier_of_ident id) + (fun id0 -> + let mut0 = { virtual_dptr = { Types.fst = id0; Types.snd = Z.OZ }; + actual_dptr = mut.actual_dptr; built_code = mut.built_code; + built_preamble = (List.Cons ({ Types.fst = id0; Types.snd = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) + (Globalenvs.size_init_data_list data)) }, mut.built_preamble)) } + in + Util.foldl do_store_init_data + (Monad.m_return0 (Monad.smax_def State.state_monad) mut0) data)) + +(** val reversed_flatten_aux : + 'a1 List.list -> 'a1 List.list List.list -> 'a1 List.list **) +let rec reversed_flatten_aux acc = function +| List.Nil -> acc +| List.Cons (hd, tl) -> reversed_flatten_aux (List.append hd acc) tl + +(** val translate_premain : + LIN.lin_program -> ASM.identifier -> (ASM.labelled_instruction List.list, + (ASM.identifier, BitVector.word) Types.prod List.list) Types.prod + Monad.smax_def__o__monad **) +let translate_premain p exit_label = + Monad.m_bind0 (Monad.smax_def State.state_monad) + (identifier_of_ident p.Joint.joint_prog.AST.prog_main) (fun main -> + Monad.m_bind0 (Monad.smax_def State.state_monad) State.state_get + (fun u -> + let dummy_dptr = { Types.fst = Positive.One; Types.snd = + (Z.zopp (Z.z_of_nat (Nat.S Nat.O))) } + in + let mut = { virtual_dptr = dummy_dptr; actual_dptr = dummy_dptr; + built_code = List.Nil; built_preamble = List.Nil } + in + Monad.m_bind0 (Monad.smax_def State.state_monad) + (Util.foldl do_store_global + (Monad.m_return0 (Monad.smax_def State.state_monad) mut) + p.Joint.joint_prog.AST.prog_vars) (fun globals_init -> + let { Types.fst = sph; Types.snd = spl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (BitVectorZ.bitvector_of_Z + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) + (Z.zopp + (Z.z_of_nat (Nat.S + (Joint.globals_stacksize + (Joint.lin_params_to_params LIN.lIN) p))))) + in + let init_isp = ASM.DATA + (Vector.append (Nat.S (Nat.S Nat.O)) + (Nat.plus (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))) (BitVector.zero (Nat.S (Nat.S Nat.O))) + (Vector.append (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))) (Vector.VCons ((Nat.S Nat.O), Bool.True, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))) + (BitVector.maximum (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))) + in + let isp_direct = ASM.DIRECT + (Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) (Nat.S Nat.O) (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))), Bool.True, + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) (Vector.VCons (Nat.O, Bool.True, + Vector.VEmpty))) + in + let reg_spl = ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons + (Nat.O, Bool.False, Vector.VEmpty)))))) + in + let reg_sph = ASM.REGISTER (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.True, (Vector.VCons + (Nat.O, Bool.True, Vector.VEmpty)))))) + in + Monad.m_return0 (Monad.smax_def State.state_monad) { Types.fst = + (List.append (List.Cons ({ Types.fst = Types.None; Types.snd = + (ASM.Cost p.Joint.init_cost_label) }, (List.Cons ({ Types.fst = + Types.None; Types.snd = (ASM.Instruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = isp_direct; + Types.snd = init_isp })))))) }, (List.Cons ({ Types.fst = + Types.None; Types.snd = (ASM.Instruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inl (Types.Inr { Types.fst = + reg_spl; Types.snd = (ASM.DATA spl) }))))))) }, (List.Cons + ({ Types.fst = Types.None; Types.snd = (ASM.Instruction (ASM.MOV + (Types.Inl (Types.Inl (Types.Inl (Types.Inl (Types.Inr + { Types.fst = reg_sph; Types.snd = (ASM.DATA sph) }))))))) }, + List.Nil)))))))) + (List.append + (reversed_flatten_aux List.Nil globals_init.built_code) + (List.Cons ({ Types.fst = Types.None; Types.snd = (ASM.Call + main) }, (List.Cons ({ Types.fst = (Types.Some exit_label); + Types.snd = (ASM.Cost u.fresh_cost_label) }, (List.Cons + ({ Types.fst = Types.None; Types.snd = (ASM.Jmp exit_label) }, + List.Nil)))))))); Types.snd = globals_init.built_preamble }))) + +(** val get_symboltable : + (ASM.identifier, AST.ident) Types.prod List.list Monad.smax_def__o__monad **) +let get_symboltable = + Obj.magic (fun u -> + let imap = u.ident_map in + let f = fun iold inew x -> List.Cons ({ Types.fst = inew; Types.snd = + iold }, x) + in + { Types.fst = u; Types.snd = + (Identifiers.foldi PreIdentifiers.SymbolTag f imap List.Nil) }) + +(** val lin_to_asm : + LIN.lin_program -> ASM.pseudo_assembly_program Types.option **) +let lin_to_asm p = + State.state_run (new_ASM_universe p) + (let add_translation = fun acc id_def -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (translate_fun_def p.Joint.jp_functions + (List.map (fun x -> x.Types.fst.Types.fst) + p.Joint.joint_prog.AST.prog_vars) id_def) (fun code -> + Monad.m_bind0 (Monad.smax_def State.state_monad) acc (fun acc0 -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (List.append code acc0))) + in + Monad.m_bind0 (Monad.smax_def State.state_monad) aSM_fresh + (fun exit_label -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (Util.foldl add_translation + (Monad.m_return0 (Monad.smax_def State.state_monad) List.Nil) + p.Joint.joint_prog.AST.prog_funct) (fun code -> + Monad.m_bind0 (Monad.smax_def State.state_monad) get_symboltable + (fun symboltable -> + Monad.m_bind2 (Monad.smax_def State.state_monad) + (translate_premain p exit_label) (fun init preamble -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (let code0 = List.append init code in + Monad.m_bind0 (Monad.max_def Option.option) + (Obj.magic (ASM.code_size_opt code0)) (fun _ -> + Monad.m_return0 (Monad.max_def Option.option) + { ASM.preamble = preamble; ASM.code = code0; + ASM.renamed_symbols = symboltable; ASM.final_label = + exit_label }))))))) + diff --git a/extracted/lINToASM.mli b/extracted/lINToASM.mli new file mode 100644 index 0000000..e0f1854 --- /dev/null +++ b/extracted/lINToASM.mli @@ -0,0 +1,356 @@ +open Preamble + +open Deqsets + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open Bool + +open Relations + +open Nat + +open BitVector + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open BitVectorTrie + +open BitVectorTrieSet + +open State + +open String + +open Exp + +open Arithmetic + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Sets + +open Listb + +open Graphs + +open I8051 + +open Order + +open Registers + +open Hide + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open LIN + +type aSM_universe = { id_univ : Identifiers.universe; + current_funct : AST.ident; + ident_map : ASM.identifier Identifiers.identifier_map; + label_map : ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map; + fresh_cost_label : Positive.pos } + +val aSM_universe_rect_Type4 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 + +val aSM_universe_rect_Type5 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 + +val aSM_universe_rect_Type3 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 + +val aSM_universe_rect_Type2 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 + +val aSM_universe_rect_Type1 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 + +val aSM_universe_rect_Type0 : + (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> 'a1) -> aSM_universe -> 'a1 + +val id_univ : aSM_universe -> Identifiers.universe + +val current_funct : aSM_universe -> AST.ident + +val ident_map : aSM_universe -> ASM.identifier Identifiers.identifier_map + +val label_map : + aSM_universe -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map + +val fresh_cost_label : aSM_universe -> Positive.pos + +val aSM_universe_inv_rect_Type4 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 + +val aSM_universe_inv_rect_Type3 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 + +val aSM_universe_inv_rect_Type2 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 + +val aSM_universe_inv_rect_Type1 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 + +val aSM_universe_inv_rect_Type0 : + aSM_universe -> (Identifiers.universe -> AST.ident -> ASM.identifier + Identifiers.identifier_map -> ASM.identifier Identifiers.identifier_map + Identifiers.identifier_map -> Positive.pos -> __ -> 'a1) -> 'a1 + +val aSM_universe_discr : aSM_universe -> aSM_universe -> __ + +val aSM_universe_jmdiscr : aSM_universe -> aSM_universe -> __ + +val report_cost : CostLabel.costlabel -> Types.unit0 Monad.smax_def__o__monad + +val identifier_of_label : + Graphs.label -> ASM.identifier Monad.smax_def__o__monad + +val identifier_of_ident : + AST.ident -> ASM.identifier Monad.smax_def__o__monad + +val new_ASM_universe : Joint.joint_program -> aSM_universe + +val start_funct_translation : + AST.ident List.list -> AST.ident List.list -> (AST.ident, + Joint.joint_function) Types.prod -> Types.unit0 Monad.smax_def__o__monad + +val aSM_fresh : ASM.identifier Monad.smax_def__o__monad + +val register_address : I8051.register -> ASM.subaddressing_mode + +val vector_cast : + Nat.nat -> Nat.nat -> 'a1 -> 'a1 Vector.vector -> 'a1 Vector.vector + +val arg_address : Joint.hdw_argument -> ASM.subaddressing_mode + +type lin_statement = Joint.joint_statement LabelledObjects.labelled_obj + +val data_of_int : BitVector.byte -> ASM.addressing_mode + +val data16_of_int : Nat.nat -> ASM.addressing_mode + +val accumulator_address : ASM.addressing_mode + +val asm_other_bit : ASM.addressing_mode + +val one_word : BitVector.word + +val translate_statements : + AST.ident List.list -> Joint.joint_statement -> ASM.pseudo_instruction + Monad.smax_def__o__monad + +val build_translated_statement : AST.ident List.list -> lin_statement -> __ + +val translate_code : AST.ident List.list -> lin_statement List.list -> __ + +val translate_fun_def : + AST.ident List.list -> AST.ident List.list -> (AST.ident, + Joint.joint_function) Types.prod -> __ + +type init_mutable = { virtual_dptr : (ASM.identifier, Z.z) Types.prod; + actual_dptr : (ASM.identifier, Z.z) Types.prod; + built_code : ASM.labelled_instruction List.list + List.list; + built_preamble : (ASM.identifier, BitVector.word) + Types.prod List.list } + +val init_mutable_rect_Type4 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 + +val init_mutable_rect_Type5 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 + +val init_mutable_rect_Type3 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 + +val init_mutable_rect_Type2 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 + +val init_mutable_rect_Type1 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 + +val init_mutable_rect_Type0 : + ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) Types.prod -> + ASM.labelled_instruction List.list List.list -> (ASM.identifier, + BitVector.word) Types.prod List.list -> 'a1) -> init_mutable -> 'a1 + +val virtual_dptr : init_mutable -> (ASM.identifier, Z.z) Types.prod + +val actual_dptr : init_mutable -> (ASM.identifier, Z.z) Types.prod + +val built_code : init_mutable -> ASM.labelled_instruction List.list List.list + +val built_preamble : + init_mutable -> (ASM.identifier, BitVector.word) Types.prod List.list + +val init_mutable_inv_rect_Type4 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) + Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> 'a1 + +val init_mutable_inv_rect_Type3 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) + Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> 'a1 + +val init_mutable_inv_rect_Type2 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) + Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> 'a1 + +val init_mutable_inv_rect_Type1 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) + Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> 'a1 + +val init_mutable_inv_rect_Type0 : + init_mutable -> ((ASM.identifier, Z.z) Types.prod -> (ASM.identifier, Z.z) + Types.prod -> ASM.labelled_instruction List.list List.list -> + (ASM.identifier, BitVector.word) Types.prod List.list -> __ -> 'a1) -> 'a1 + +val init_mutable_discr : init_mutable -> init_mutable -> __ + +val init_mutable_jmdiscr : init_mutable -> init_mutable -> __ + +val store_byte_or_Identifier : + (BitVector.byte, (ASM.word_side, ASM.identifier) Types.prod) Types.sum -> + init_mutable -> init_mutable + +val do_store_init_data : + init_mutable Monad.smax_def__o__monad -> AST.init_data -> init_mutable + Monad.smax_def__o__monad + +val do_store_global : + init_mutable Monad.smax_def__o__monad -> ((AST.ident, AST.region) + Types.prod, AST.init_data List.list) Types.prod -> init_mutable + Monad.smax_def__o__monad + +val reversed_flatten_aux : + 'a1 List.list -> 'a1 List.list List.list -> 'a1 List.list + +val translate_premain : + LIN.lin_program -> ASM.identifier -> (ASM.labelled_instruction List.list, + (ASM.identifier, BitVector.word) Types.prod List.list) Types.prod + Monad.smax_def__o__monad + +val get_symboltable : + (ASM.identifier, AST.ident) Types.prod List.list Monad.smax_def__o__monad + +val lin_to_asm : LIN.lin_program -> ASM.pseudo_assembly_program Types.option + diff --git a/extracted/lIN_printer.ml b/extracted/lIN_printer.ml new file mode 100644 index 0000000..e55d145 --- /dev/null +++ b/extracted/lIN_printer.ml @@ -0,0 +1,135 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open Joint_LTL_LIN + +open LIN + +(** val print_LIN_program : + 'a1 Joint_printer.printing_params -> LIN.lin_program -> (AST.ident, 'a1 + List.list) Types.prod List.list **) +let print_LIN_program pp prog = + Joint_printer.print_joint_program (Joint.lin_params_to_params LIN.lIN) pp + prog + (Joint_printer.lin_code_iteration_params LIN.lIN + (Joint.prog_names (Joint.lin_params_to_params LIN.lIN) prog) pp) + diff --git a/extracted/lIN_printer.mli b/extracted/lIN_printer.mli new file mode 100644 index 0000000..8e7d0a2 --- /dev/null +++ b/extracted/lIN_printer.mli @@ -0,0 +1,130 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open Joint_LTL_LIN + +open LIN + +val print_LIN_program : + 'a1 Joint_printer.printing_params -> LIN.lin_program -> (AST.ident, 'a1 + List.list) Types.prod List.list + diff --git a/extracted/lIN_semantics.ml b/extracted/lIN_semantics.ml new file mode 100644 index 0000000..e86860c --- /dev/null +++ b/extracted/lIN_semantics.ml @@ -0,0 +1,164 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Events + +open IOMonad + +open IO + +open Joint_semantics + +open SemanticsUtils + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open Joint_LTL_LIN_semantics + +open LIN + +(** val lIN_semantics : Joint_semantics.sem_params **) +let lIN_semantics = + SemanticsUtils.sem_lin_params_to_sem_params { SemanticsUtils.slp_pars = + (Joint.lp_to_p__o__stmt_pars__o__uns_pars LIN.lIN); + SemanticsUtils.slp_sup = (fun _ -> + Joint_LTL_LIN_semantics.lTL_LIN_semantics); + SemanticsUtils.lin_pre_main_generator = LIN.lIN_premain } + diff --git a/extracted/lIN_semantics.mli b/extracted/lIN_semantics.mli new file mode 100644 index 0000000..7f028c8 --- /dev/null +++ b/extracted/lIN_semantics.mli @@ -0,0 +1,158 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Events + +open IOMonad + +open IO + +open Joint_semantics + +open SemanticsUtils + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open Joint_LTL_LIN_semantics + +open LIN + +val lIN_semantics : Joint_semantics.sem_params + diff --git a/extracted/lTL.ml b/extracted/lTL.ml new file mode 100644 index 0000000..d96d6be --- /dev/null +++ b/extracted/lTL.ml @@ -0,0 +1,211 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +(** val lTL : Joint.graph_params **) +let lTL = + Joint_LTL_LIN.lTL_LIN + +type ltl_program = Joint.joint_program + +(** val dpi1__o__byte_to_ltl_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> Joint.hdw_argument Types.sig0 **) +let dpi1__o__byte_to_ltl_argument__o__inject x2 = + Joint.hdw_argument_from_byte x2.Types.dpi1 + +(** val eject__o__byte_to_ltl_argument__o__inject : + BitVector.byte Types.sig0 -> Joint.hdw_argument Types.sig0 **) +let eject__o__byte_to_ltl_argument__o__inject x2 = + Joint.hdw_argument_from_byte (Types.pi1 x2) + +(** val byte_to_ltl_argument__o__inject : + BitVector.byte -> Joint.hdw_argument Types.sig0 **) +let byte_to_ltl_argument__o__inject x1 = + Joint.hdw_argument_from_byte x1 + +(** val dpi1__o__byte_to_ltl_argument : + (BitVector.byte, 'a1) Types.dPair -> Joint.hdw_argument **) +let dpi1__o__byte_to_ltl_argument x1 = + Joint.hdw_argument_from_byte x1.Types.dpi1 + +(** val eject__o__byte_to_ltl_argument : + BitVector.byte Types.sig0 -> Joint.hdw_argument **) +let eject__o__byte_to_ltl_argument x1 = + Joint.hdw_argument_from_byte (Types.pi1 x1) + +(** val dpi1__o__reg_to_ltl_argument__o__inject : + (I8051.register, 'a1) Types.dPair -> Joint.hdw_argument Types.sig0 **) +let dpi1__o__reg_to_ltl_argument__o__inject x2 = + Joint.hdw_argument_from_reg x2.Types.dpi1 + +(** val eject__o__reg_to_ltl_argument__o__inject : + I8051.register Types.sig0 -> Joint.hdw_argument Types.sig0 **) +let eject__o__reg_to_ltl_argument__o__inject x2 = + Joint.hdw_argument_from_reg (Types.pi1 x2) + +(** val reg_to_ltl_argument__o__inject : + I8051.register -> Joint.hdw_argument Types.sig0 **) +let reg_to_ltl_argument__o__inject x1 = + Joint.hdw_argument_from_reg x1 + +(** val dpi1__o__reg_to_ltl_argument : + (I8051.register, 'a1) Types.dPair -> Joint.hdw_argument **) +let dpi1__o__reg_to_ltl_argument x1 = + Joint.hdw_argument_from_reg x1.Types.dpi1 + +(** val eject__o__reg_to_ltl_argument : + I8051.register Types.sig0 -> Joint.hdw_argument **) +let eject__o__reg_to_ltl_argument x1 = + Joint.hdw_argument_from_reg (Types.pi1 x1) + +(** val lTL_premain : ltl_program -> Joint.joint_closed_internal_function **) +let lTL_premain p = + let l1 = Positive.One in + let l2 = Positive.P0 Positive.One in + let l3 = Positive.P1 Positive.One in + let res = { Joint.joint_if_luniverse = (Positive.P0 (Positive.P0 + Positive.One)); Joint.joint_if_runiverse = Positive.One; + Joint.joint_if_result = (Obj.magic Types.It); Joint.joint_if_params = + (Obj.magic Types.It); Joint.joint_if_stacksize = Nat.O; + Joint.joint_if_local_stacksize = Nat.O; Joint.joint_if_code = + (Obj.magic (Identifiers.empty_map PreIdentifiers.LabelTag)); + Joint.joint_if_entry = (Obj.magic l1) } + in + let res0 = + Joint.add_graph lTL + (Joint.prog_names (Joint.graph_params_to_params lTL) p) l1 + (Joint.Sequential ((Joint.COST_LABEL p.Joint.init_cost_label), + (Obj.magic l2))) res + in + let res1 = + Joint.add_graph lTL + (Joint.prog_names (Joint.graph_params_to_params lTL) p) l2 + (Joint.Sequential ((Joint.CALL ((Types.Inl + p.Joint.joint_prog.AST.prog_main), (Obj.magic Nat.O), + (Obj.magic Types.It))), (Obj.magic l3))) res0 + in + let res2 = + Joint.add_graph lTL + (Joint.prog_names (Joint.graph_params_to_params lTL) p) l3 (Joint.Final + (Joint.GOTO l3)) res1 + in + res2 + diff --git a/extracted/lTL.mli b/extracted/lTL.mli new file mode 100644 index 0000000..493db82 --- /dev/null +++ b/extracted/lTL.mli @@ -0,0 +1,158 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +val lTL : Joint.graph_params + +type ltl_program = Joint.joint_program + +val dpi1__o__byte_to_ltl_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> Joint.hdw_argument Types.sig0 + +val eject__o__byte_to_ltl_argument__o__inject : + BitVector.byte Types.sig0 -> Joint.hdw_argument Types.sig0 + +val byte_to_ltl_argument__o__inject : + BitVector.byte -> Joint.hdw_argument Types.sig0 + +val dpi1__o__byte_to_ltl_argument : + (BitVector.byte, 'a1) Types.dPair -> Joint.hdw_argument + +val eject__o__byte_to_ltl_argument : + BitVector.byte Types.sig0 -> Joint.hdw_argument + +val dpi1__o__reg_to_ltl_argument__o__inject : + (I8051.register, 'a1) Types.dPair -> Joint.hdw_argument Types.sig0 + +val eject__o__reg_to_ltl_argument__o__inject : + I8051.register Types.sig0 -> Joint.hdw_argument Types.sig0 + +val reg_to_ltl_argument__o__inject : + I8051.register -> Joint.hdw_argument Types.sig0 + +val dpi1__o__reg_to_ltl_argument : + (I8051.register, 'a1) Types.dPair -> Joint.hdw_argument + +val eject__o__reg_to_ltl_argument : + I8051.register Types.sig0 -> Joint.hdw_argument + +val lTL_premain : ltl_program -> Joint.joint_closed_internal_function + diff --git a/extracted/lTLToLIN.ml b/extracted/lTLToLIN.ml new file mode 100644 index 0000000..cb0c8fb --- /dev/null +++ b/extracted/lTLToLIN.ml @@ -0,0 +1,132 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Linearise + +open Joint_LTL_LIN + +open LTL + +open LIN + +(** val ltl_to_lin : LTL.ltl_program -> LIN.lin_program **) +let ltl_to_lin = + Linearise.linearise Joint_LTL_LIN.lTL_LIN + diff --git a/extracted/lTLToLIN.mli b/extracted/lTLToLIN.mli new file mode 100644 index 0000000..d3eae38 --- /dev/null +++ b/extracted/lTLToLIN.mli @@ -0,0 +1,130 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Linearise + +open Joint_LTL_LIN + +open LTL + +open LIN + +val ltl_to_lin : LTL.ltl_program -> LIN.lin_program + diff --git a/extracted/lTL_printer.ml b/extracted/lTL_printer.ml new file mode 100644 index 0000000..5faff0b --- /dev/null +++ b/extracted/lTL_printer.ml @@ -0,0 +1,135 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open Joint_LTL_LIN + +open LTL + +(** val print_LTL_program : + 'a1 Joint_printer.printing_params -> LTL.ltl_program -> (AST.ident, 'a1 + List.list) Types.prod List.list **) +let print_LTL_program pp prog = + Joint_printer.print_joint_program (Joint.graph_params_to_params LTL.lTL) pp + prog + (Joint_printer.graph_code_iteration_params LTL.lTL + (Joint.prog_names (Joint.graph_params_to_params LTL.lTL) prog) pp) + diff --git a/extracted/lTL_printer.mli b/extracted/lTL_printer.mli new file mode 100644 index 0000000..c35becc --- /dev/null +++ b/extracted/lTL_printer.mli @@ -0,0 +1,130 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open Joint_LTL_LIN + +open LTL + +val print_LTL_program : + 'a1 Joint_printer.printing_params -> LTL.ltl_program -> (AST.ident, 'a1 + List.list) Types.prod List.list + diff --git a/extracted/lTL_semantics.ml b/extracted/lTL_semantics.ml new file mode 100644 index 0000000..2b868f7 --- /dev/null +++ b/extracted/lTL_semantics.ml @@ -0,0 +1,164 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Events + +open IOMonad + +open IO + +open Joint_semantics + +open SemanticsUtils + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open Joint_LTL_LIN_semantics + +open LTL + +(** val lTL_semantics : SemanticsUtils.sem_graph_params **) +let lTL_semantics = + { SemanticsUtils.sgp_pars = + (Joint.gp_to_p__o__stmt_pars__o__uns_pars LTL.lTL); + SemanticsUtils.sgp_sup = (fun _ -> + Joint_LTL_LIN_semantics.lTL_LIN_semantics); + SemanticsUtils.graph_pre_main_generator = LTL.lTL_premain } + diff --git a/extracted/lTL_semantics.mli b/extracted/lTL_semantics.mli new file mode 100644 index 0000000..568344c --- /dev/null +++ b/extracted/lTL_semantics.mli @@ -0,0 +1,158 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Events + +open IOMonad + +open IO + +open Joint_semantics + +open SemanticsUtils + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_LTL_LIN + +open Joint_LTL_LIN_semantics + +open LTL + +val lTL_semantics : SemanticsUtils.sem_graph_params + diff --git a/extracted/label.ml b/extracted/label.ml new file mode 100644 index 0000000..8f31009 --- /dev/null +++ b/extracted/label.ml @@ -0,0 +1,709 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +(** val labels_of_expr : Csyntax.expr -> CostLabel.costlabel List.list **) +let rec labels_of_expr = function +| Csyntax.Expr (e', x) -> + (match e' with + | Csyntax.Econst_int (x0, x1) -> List.Nil + | Csyntax.Evar x0 -> List.Nil + | Csyntax.Ederef e1 -> labels_of_expr e1 + | Csyntax.Eaddrof e1 -> labels_of_expr e1 + | Csyntax.Eunop (x0, e1) -> labels_of_expr e1 + | Csyntax.Ebinop (x0, e1, e2) -> + List.append (labels_of_expr e1) (labels_of_expr e2) + | Csyntax.Ecast (x0, e1) -> labels_of_expr e1 + | Csyntax.Econdition (e1, e2, e3) -> + List.append (labels_of_expr e1) + (List.append (labels_of_expr e2) (labels_of_expr e3)) + | Csyntax.Eandbool (e1, e2) -> + List.append (labels_of_expr e1) (labels_of_expr e2) + | Csyntax.Eorbool (e1, e2) -> + List.append (labels_of_expr e1) (labels_of_expr e2) + | Csyntax.Esizeof x0 -> List.Nil + | Csyntax.Efield (e1, x0) -> labels_of_expr e1 + | Csyntax.Ecost (cl, e1) -> List.Cons (cl, (labels_of_expr e1))) + +(** val labels_of_statement : + Csyntax.statement -> CostLabel.costlabel List.list **) +let rec labels_of_statement = function +| Csyntax.Sskip -> List.Nil +| Csyntax.Sassign (e1, e2) -> + List.append (labels_of_expr e1) (labels_of_expr e2) +| Csyntax.Scall (oe, e1, es) -> + List.append (Types.option_map_def labels_of_expr List.Nil oe) + (List.append (labels_of_expr e1) + (Util.foldl (fun ls e -> List.append (labels_of_expr e) ls) List.Nil + es)) +| Csyntax.Ssequence (s1, s2) -> + List.append (labels_of_statement s1) (labels_of_statement s2) +| Csyntax.Sifthenelse (e1, s1, s2) -> + List.append (labels_of_expr e1) + (List.append (labels_of_statement s1) (labels_of_statement s2)) +| Csyntax.Swhile (e1, s1) -> + List.append (labels_of_expr e1) (labels_of_statement s1) +| Csyntax.Sdowhile (e1, s1) -> + List.append (labels_of_expr e1) (labels_of_statement s1) +| Csyntax.Sfor (s1, e1, s2, s3) -> + List.append (labels_of_statement s1) + (List.append (labels_of_expr e1) + (List.append (labels_of_statement s2) (labels_of_statement s3))) +| Csyntax.Sbreak -> List.Nil +| Csyntax.Scontinue -> List.Nil +| Csyntax.Sreturn oe -> Types.option_map_def labels_of_expr List.Nil oe +| Csyntax.Sswitch (e1, ls) -> + List.append (labels_of_expr e1) (labels_of_labeled_statements ls) +| Csyntax.Slabel (x, s1) -> labels_of_statement s1 +| Csyntax.Sgoto x -> List.Nil +| Csyntax.Scost (cl, s1) -> List.Cons (cl, (labels_of_statement s1)) +(** val labels_of_labeled_statements : + Csyntax.labeled_statements -> CostLabel.costlabel List.list **) +and labels_of_labeled_statements = function +| Csyntax.LSdefault s1 -> labels_of_statement s1 +| Csyntax.LScase (x, x0, s1, ls1) -> + List.append (labels_of_statement s1) (labels_of_labeled_statements ls1) + +(** val labels_of_clight_fundef : + (AST.ident, Csyntax.clight_fundef) Types.prod -> CostLabel.costlabel + List.list **) +let labels_of_clight_fundef ifd = + match ifd.Types.snd with + | Csyntax.CL_Internal f -> labels_of_statement f.Csyntax.fn_body + | Csyntax.CL_External (x, x0, x1) -> List.Nil + +(** val labels_of_clight : + Csyntax.clight_program -> CostLabel.costlabel List.list **) +let labels_of_clight p = + Util.foldl (fun ls f -> List.append (labels_of_clight_fundef f) ls) + List.Nil p.AST.prog_funct + +type in_clight_label = CostLabel.costlabel Types.sig0 + +type clight_cost_map = CostLabel.costlabel -> Nat.nat + +(** val clight_label_free : Csyntax.clight_program -> Bool.bool **) +let clight_label_free p = + match labels_of_clight p with + | List.Nil -> Bool.True + | List.Cons (x, x0) -> Bool.False + +(** val add_cost_before : + Csyntax.statement -> Identifiers.universe -> (Csyntax.statement, + Identifiers.universe) Types.prod **) +let add_cost_before s gen = + let { Types.fst = l; Types.snd = gen0 } = + Identifiers.fresh PreIdentifiers.CostTag gen + in + { Types.fst = (Csyntax.Scost (l, s)); Types.snd = gen0 } + +(** val add_cost_after : + Csyntax.statement -> Identifiers.universe -> (Csyntax.statement, + Identifiers.universe) Types.prod **) +let add_cost_after s gen = + let { Types.fst = l; Types.snd = gen0 } = + Identifiers.fresh PreIdentifiers.CostTag gen + in + { Types.fst = (Csyntax.Ssequence (s, (Csyntax.Scost (l, Csyntax.Sskip)))); + Types.snd = gen0 } + +(** val add_cost_expr : + Csyntax.expr -> Identifiers.universe -> (Csyntax.expr, + Identifiers.universe) Types.prod **) +let add_cost_expr e gen = + let { Types.fst = l; Types.snd = gen0 } = + Identifiers.fresh PreIdentifiers.CostTag gen + in + { Types.fst = (Csyntax.Expr ((Csyntax.Ecost (l, e)), (Csyntax.typeof e))); + Types.snd = gen0 } + +(** val const_int : AST.intsize -> Nat.nat -> Csyntax.expr **) +let const_int sz n = + Csyntax.Expr ((Csyntax.Econst_int (sz, (AST.repr sz n))), (Csyntax.Tint + (sz, AST.Signed))) + +(** val label_expr : + Csyntax.expr -> Identifiers.universe -> (Csyntax.expr, + Identifiers.universe) Types.prod **) +let rec label_expr e costgen = + let Csyntax.Expr (ed, ty) = e in + let { Types.fst = ed0; Types.snd = costgen0 } = + label_expr_descr ed costgen ty + in + { Types.fst = (Csyntax.Expr (ed0, ty)); Types.snd = costgen0 } +(** val label_expr_descr : + Csyntax.expr_descr -> Identifiers.universe -> Csyntax.type0 -> + (Csyntax.expr_descr, Identifiers.universe) Types.prod **) +and label_expr_descr e costgen ty = + match e with + | Csyntax.Econst_int (x, x0) -> { Types.fst = e; Types.snd = costgen } + | Csyntax.Evar x -> { Types.fst = e; Types.snd = costgen } + | Csyntax.Ederef e' -> + let { Types.fst = e'0; Types.snd = costgen0 } = label_expr e' costgen in + { Types.fst = (Csyntax.Ederef e'0); Types.snd = costgen0 } + | Csyntax.Eaddrof e' -> + let { Types.fst = e'0; Types.snd = costgen0 } = label_expr e' costgen in + { Types.fst = (Csyntax.Eaddrof e'0); Types.snd = costgen0 } + | Csyntax.Eunop (op, e') -> + let { Types.fst = e'0; Types.snd = costgen0 } = label_expr e' costgen in + { Types.fst = (Csyntax.Eunop (op, e'0)); Types.snd = costgen0 } + | Csyntax.Ebinop (op, e1, e2) -> + let { Types.fst = e10; Types.snd = costgen0 } = label_expr e1 costgen in + let { Types.fst = e20; Types.snd = costgen1 } = label_expr e2 costgen0 in + { Types.fst = (Csyntax.Ebinop (op, e10, e20)); Types.snd = costgen1 } + | Csyntax.Ecast (ty0, e') -> + let { Types.fst = e'0; Types.snd = costgen0 } = label_expr e' costgen in + { Types.fst = (Csyntax.Ecast (ty0, e'0)); Types.snd = costgen0 } + | Csyntax.Econdition (e', e1, e2) -> + let { Types.fst = e'0; Types.snd = costgen0 } = label_expr e' costgen in + let { Types.fst = e10; Types.snd = costgen1 } = label_expr e1 costgen0 in + let { Types.fst = e11; Types.snd = costgen2 } = + add_cost_expr e10 costgen1 + in + let { Types.fst = e20; Types.snd = costgen3 } = label_expr e2 costgen2 in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr e20 costgen3 + in + { Types.fst = (Csyntax.Econdition (e'0, e11, e21)); Types.snd = + costgen4 } + | Csyntax.Eandbool (e1, e2) -> + let { Types.fst = e10; Types.snd = costgen0 } = label_expr e1 costgen in + let { Types.fst = e20; Types.snd = costgen1 } = label_expr e2 costgen0 in + (match ty with + | Csyntax.Tvoid -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 } + | Csyntax.Tint (sz, sg) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int sz (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int sz Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int sz Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 } + | Csyntax.Tpointer x -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 } + | Csyntax.Tarray (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 } + | Csyntax.Tfunction (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 } + | Csyntax.Tstruct (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 } + | Csyntax.Tunion (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 } + | Csyntax.Tcomp_ptr x -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = ef0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, e21, ef0)); Types.snd = + costgen5 }) + | Csyntax.Eorbool (e1, e2) -> + let { Types.fst = e10; Types.snd = costgen0 } = label_expr e1 costgen in + let { Types.fst = e20; Types.snd = costgen1 } = label_expr e2 costgen0 in + (match ty with + | Csyntax.Tvoid -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 } + | Csyntax.Tint (sz, sg) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int sz (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int sz Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int sz (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 } + | Csyntax.Tpointer x -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 } + | Csyntax.Tarray (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 } + | Csyntax.Tfunction (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 } + | Csyntax.Tstruct (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 } + | Csyntax.Tunion (x, x0) -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 } + | Csyntax.Tcomp_ptr x -> + let { Types.fst = et; Types.snd = costgen2 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen1 + in + let { Types.fst = ef; Types.snd = costgen3 } = + add_cost_expr (const_int AST.I32 Nat.O) costgen2 + in + let { Types.fst = e21; Types.snd = costgen4 } = + add_cost_expr (Csyntax.Expr ((Csyntax.Econdition (e20, et, ef)), + ty)) costgen3 + in + let { Types.fst = et0; Types.snd = costgen5 } = + add_cost_expr (const_int AST.I32 (Nat.S Nat.O)) costgen4 + in + { Types.fst = (Csyntax.Econdition (e10, et0, e21)); Types.snd = + costgen5 }) + | Csyntax.Esizeof x -> { Types.fst = e; Types.snd = costgen } + | Csyntax.Efield (e', id) -> + let { Types.fst = e'0; Types.snd = costgen0 } = label_expr e' costgen in + { Types.fst = (Csyntax.Efield (e'0, id)); Types.snd = costgen0 } + | Csyntax.Ecost (l, e') -> + let { Types.fst = e'0; Types.snd = costgen0 } = label_expr e' costgen in + { Types.fst = (Csyntax.Ecost (l, e'0)); Types.snd = costgen0 } + +(** val label_exprs : + Csyntax.expr List.list -> Identifiers.universe -> (Csyntax.expr + List.list, Identifiers.universe) Types.prod **) +let rec label_exprs l costgen = + match l with + | List.Nil -> { Types.fst = List.Nil; Types.snd = costgen } + | List.Cons (e, es) -> + let { Types.fst = e0; Types.snd = costgen0 } = label_expr e costgen in + let { Types.fst = es0; Types.snd = costgen1 } = label_exprs es costgen0 + in + { Types.fst = (List.Cons (e0, es0)); Types.snd = costgen1 } + +(** val label_opt_expr : + Csyntax.expr Types.option -> Identifiers.universe -> (Csyntax.expr + Types.option, Identifiers.universe) Types.prod **) +let label_opt_expr oe costgen = + match oe with + | Types.None -> { Types.fst = Types.None; Types.snd = costgen } + | Types.Some e -> + let { Types.fst = e0; Types.snd = costgen0 } = label_expr e costgen in + { Types.fst = (Types.Some e0); Types.snd = costgen0 } + +(** val label_statement : + Csyntax.statement -> Identifiers.universe -> (Csyntax.statement, + Identifiers.universe) Types.prod **) +let rec label_statement s costgen = + match s with + | Csyntax.Sskip -> { Types.fst = Csyntax.Sskip; Types.snd = costgen } + | Csyntax.Sassign (e1, e2) -> + let { Types.fst = e10; Types.snd = costgen0 } = label_expr e1 costgen in + let { Types.fst = e20; Types.snd = costgen1 } = label_expr e2 costgen0 in + { Types.fst = (Csyntax.Sassign (e10, e20)); Types.snd = costgen1 } + | Csyntax.Scall (e_ret, e_fn, e_args) -> + let { Types.fst = e_ret0; Types.snd = costgen0 } = + label_opt_expr e_ret costgen + in + let { Types.fst = e_fn0; Types.snd = costgen1 } = + label_expr e_fn costgen0 + in + let { Types.fst = e_args0; Types.snd = costgen2 } = + label_exprs e_args costgen1 + in + { Types.fst = (Csyntax.Scall (e_ret0, e_fn0, e_args0)); Types.snd = + costgen2 } + | Csyntax.Ssequence (s1, s2) -> + let { Types.fst = s10; Types.snd = costgen0 } = + label_statement s1 costgen + in + let { Types.fst = s20; Types.snd = costgen1 } = + label_statement s2 costgen0 + in + { Types.fst = (Csyntax.Ssequence (s10, s20)); Types.snd = costgen1 } + | Csyntax.Sifthenelse (e, s1, s2) -> + let { Types.fst = e0; Types.snd = costgen0 } = label_expr e costgen in + let { Types.fst = s10; Types.snd = costgen1 } = + label_statement s1 costgen0 + in + let { Types.fst = s11; Types.snd = costgen2 } = + add_cost_before s10 costgen1 + in + let { Types.fst = s20; Types.snd = costgen3 } = + label_statement s2 costgen2 + in + let { Types.fst = s21; Types.snd = costgen4 } = + add_cost_before s20 costgen3 + in + { Types.fst = (Csyntax.Sifthenelse (e0, s11, s21)); Types.snd = + costgen4 } + | Csyntax.Swhile (e, s') -> + let { Types.fst = e0; Types.snd = costgen0 } = label_expr e costgen in + let { Types.fst = s'0; Types.snd = costgen1 } = + label_statement s' costgen0 + in + let { Types.fst = s'1; Types.snd = costgen2 } = + add_cost_before s'0 costgen1 + in + let { Types.fst = s0; Types.snd = costgen3 } = + add_cost_after (Csyntax.Swhile (e0, s'1)) costgen2 + in + { Types.fst = s0; Types.snd = costgen3 } + | Csyntax.Sdowhile (e, s') -> + let { Types.fst = e0; Types.snd = costgen0 } = label_expr e costgen in + let { Types.fst = s'0; Types.snd = costgen1 } = + label_statement s' costgen0 + in + let { Types.fst = s'1; Types.snd = costgen2 } = + add_cost_before s'0 costgen1 + in + let { Types.fst = s0; Types.snd = costgen3 } = + add_cost_after (Csyntax.Sdowhile (e0, s'1)) costgen2 + in + { Types.fst = s0; Types.snd = costgen3 } + | Csyntax.Sfor (s1, e, s2, s3) -> + let { Types.fst = e0; Types.snd = costgen0 } = label_expr e costgen in + let { Types.fst = s10; Types.snd = costgen1 } = + label_statement s1 costgen0 + in + let { Types.fst = s20; Types.snd = costgen2 } = + label_statement s2 costgen1 + in + let { Types.fst = s30; Types.snd = costgen3 } = + label_statement s3 costgen2 + in + let { Types.fst = s31; Types.snd = costgen4 } = + add_cost_before s30 costgen3 + in + let { Types.fst = s0; Types.snd = costgen5 } = + add_cost_after (Csyntax.Sfor (s10, e0, s20, s31)) costgen4 + in + { Types.fst = s0; Types.snd = costgen5 } + | Csyntax.Sbreak -> { Types.fst = Csyntax.Sbreak; Types.snd = costgen } + | Csyntax.Scontinue -> + { Types.fst = Csyntax.Scontinue; Types.snd = costgen } + | Csyntax.Sreturn opt_e -> + let { Types.fst = opt_e0; Types.snd = costgen0 } = + label_opt_expr opt_e costgen + in + { Types.fst = (Csyntax.Sreturn opt_e0); Types.snd = costgen0 } + | Csyntax.Sswitch (e, ls) -> + let { Types.fst = e0; Types.snd = costgen0 } = label_expr e costgen in + let { Types.fst = ls0; Types.snd = costgen1 } = + label_lstatements ls costgen0 + in + { Types.fst = (Csyntax.Sswitch (e0, ls0)); Types.snd = costgen1 } + | Csyntax.Slabel (l, s') -> + let { Types.fst = s'0; Types.snd = costgen0 } = + label_statement s' costgen + in + let { Types.fst = s'1; Types.snd = costgen1 } = + add_cost_before s'0 costgen0 + in + { Types.fst = (Csyntax.Slabel (l, s'1)); Types.snd = costgen1 } + | Csyntax.Sgoto l -> { Types.fst = (Csyntax.Sgoto l); Types.snd = costgen } + | Csyntax.Scost (l, s') -> + let { Types.fst = s'0; Types.snd = costgen0 } = + label_statement s' costgen + in + { Types.fst = (Csyntax.Scost (l, s'0)); Types.snd = costgen0 } +(** val label_lstatements : + Csyntax.labeled_statements -> Identifiers.universe -> + (Csyntax.labeled_statements, Identifiers.universe) Types.prod **) +and label_lstatements ls costgen = + match ls with + | Csyntax.LSdefault s -> + let { Types.fst = s0; Types.snd = costgen0 } = label_statement s costgen + in + let { Types.fst = s1; Types.snd = costgen1 } = + add_cost_before s0 costgen0 + in + { Types.fst = (Csyntax.LSdefault s1); Types.snd = costgen1 } + | Csyntax.LScase (sz, i, s, ls') -> + let { Types.fst = s0; Types.snd = costgen0 } = label_statement s costgen + in + let { Types.fst = s1; Types.snd = costgen1 } = + add_cost_before s0 costgen0 + in + let { Types.fst = ls'0; Types.snd = costgen2 } = + label_lstatements ls' costgen1 + in + { Types.fst = (Csyntax.LScase (sz, i, s1, ls'0)); Types.snd = costgen2 } + +(** val label_function : + Identifiers.universe -> Csyntax.function0 -> (Csyntax.function0, + Identifiers.universe) Types.prod **) +let label_function costgen f = + let { Types.fst = body; Types.snd = costgen0 } = + label_statement f.Csyntax.fn_body costgen + in + let { Types.fst = body0; Types.snd = costgen1 } = + add_cost_before body costgen0 + in + { Types.fst = { Csyntax.fn_return = f.Csyntax.fn_return; + Csyntax.fn_params = f.Csyntax.fn_params; Csyntax.fn_vars = + f.Csyntax.fn_vars; Csyntax.fn_body = body0 }; Types.snd = costgen1 } + +(** val label_fundef : + Identifiers.universe -> Csyntax.clight_fundef -> (Csyntax.clight_fundef, + Identifiers.universe) Types.prod **) +let label_fundef gen = function +| Csyntax.CL_Internal f0 -> + let { Types.fst = f'; Types.snd = gen' } = label_function gen f0 in + { Types.fst = (Csyntax.CL_Internal f'); Types.snd = gen' } +| Csyntax.CL_External (id, args, ty) -> + { Types.fst = (Csyntax.CL_External (id, args, ty)); Types.snd = gen } + +(** val clight_label : + Csyntax.clight_program -> (Csyntax.clight_program, CostLabel.costlabel) + Types.prod **) +let rec clight_label p = + let costgen = Identifiers.new_universe PreIdentifiers.CostTag in + let { Types.fst = init_cost; Types.snd = costgen0 } = + Identifiers.fresh PreIdentifiers.CostTag costgen + in + { Types.fst = + (AST.transform_program_gen PreIdentifiers.CostTag costgen0 p (fun x -> + label_fundef)).Types.fst; Types.snd = init_cost } + diff --git a/extracted/label.mli b/extracted/label.mli new file mode 100644 index 0000000..d2d4bb5 --- /dev/null +++ b/extracted/label.mli @@ -0,0 +1,146 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +val labels_of_expr : Csyntax.expr -> CostLabel.costlabel List.list + +val labels_of_labeled_statements : + Csyntax.labeled_statements -> CostLabel.costlabel List.list + +val labels_of_statement : Csyntax.statement -> CostLabel.costlabel List.list + +val labels_of_clight_fundef : + (AST.ident, Csyntax.clight_fundef) Types.prod -> CostLabel.costlabel + List.list + +val labels_of_clight : + Csyntax.clight_program -> CostLabel.costlabel List.list + +type in_clight_label = CostLabel.costlabel Types.sig0 + +type clight_cost_map = CostLabel.costlabel -> Nat.nat + +val clight_label_free : Csyntax.clight_program -> Bool.bool + +val add_cost_before : + Csyntax.statement -> Identifiers.universe -> (Csyntax.statement, + Identifiers.universe) Types.prod + +val add_cost_after : + Csyntax.statement -> Identifiers.universe -> (Csyntax.statement, + Identifiers.universe) Types.prod + +val add_cost_expr : + Csyntax.expr -> Identifiers.universe -> (Csyntax.expr, + Identifiers.universe) Types.prod + +val const_int : AST.intsize -> Nat.nat -> Csyntax.expr + +val label_expr_descr : + Csyntax.expr_descr -> Identifiers.universe -> Csyntax.type0 -> + (Csyntax.expr_descr, Identifiers.universe) Types.prod + +val label_expr : + Csyntax.expr -> Identifiers.universe -> (Csyntax.expr, + Identifiers.universe) Types.prod + +val label_exprs : + Csyntax.expr List.list -> Identifiers.universe -> (Csyntax.expr List.list, + Identifiers.universe) Types.prod + +val label_opt_expr : + Csyntax.expr Types.option -> Identifiers.universe -> (Csyntax.expr + Types.option, Identifiers.universe) Types.prod + +val label_lstatements : + Csyntax.labeled_statements -> Identifiers.universe -> + (Csyntax.labeled_statements, Identifiers.universe) Types.prod + +val label_statement : + Csyntax.statement -> Identifiers.universe -> (Csyntax.statement, + Identifiers.universe) Types.prod + +val label_function : + Identifiers.universe -> Csyntax.function0 -> (Csyntax.function0, + Identifiers.universe) Types.prod + +val label_fundef : + Identifiers.universe -> Csyntax.clight_fundef -> (Csyntax.clight_fundef, + Identifiers.universe) Types.prod + +val clight_label : + Csyntax.clight_program -> (Csyntax.clight_program, CostLabel.costlabel) + Types.prod + diff --git a/extracted/labelledObjects.ml b/extracted/labelledObjects.ml new file mode 100644 index 0000000..fc5d82b --- /dev/null +++ b/extracted/labelledObjects.ml @@ -0,0 +1,104 @@ +open Preamble + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Lists + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Positive + +open Identifiers + +type 'a labelled_obj = + (PreIdentifiers.identifier Types.option, 'a) Types.prod + +(** val instruction_matches_identifier : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj -> Bool.bool **) +let instruction_matches_identifier tag y x = + match x.Types.fst with + | Types.None -> Bool.False + | Types.Some x0 -> Identifiers.eq_identifier tag x0 y + +(** val does_not_occur : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj List.list -> Bool.bool **) +let rec does_not_occur tag id = function +| List.Nil -> Bool.True +| List.Cons (x, l0) -> + Bool.andb (Bool.notb (instruction_matches_identifier tag id x)) + (does_not_occur tag id l0) + +(** val occurs_exactly_once : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj List.list -> Bool.bool **) +let rec occurs_exactly_once tag id = function +| List.Nil -> Bool.False +| List.Cons (x, l0) -> + (match instruction_matches_identifier tag id x with + | Bool.True -> does_not_occur tag id l0 + | Bool.False -> occurs_exactly_once tag id l0) + +(** val index_of_internal : + ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat -> Nat.nat **) +let rec index_of_internal test l acc = + match l with + | List.Nil -> assert false (* absurd case *) + | List.Cons (x, tl) -> + (match test x with + | Bool.True -> acc + | Bool.False -> index_of_internal test tl (Nat.S acc)) + +(** val index_of : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat **) +let index_of test l = + index_of_internal test l Nat.O + +(** val index_of_label : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj List.list -> Nat.nat **) +let index_of_label tag l = + index_of (instruction_matches_identifier tag l) + diff --git a/extracted/labelledObjects.mli b/extracted/labelledObjects.mli new file mode 100644 index 0000000..0d2566d --- /dev/null +++ b/extracted/labelledObjects.mli @@ -0,0 +1,78 @@ +open Preamble + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Lists + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Positive + +open Identifiers + +type 'a labelled_obj = + (PreIdentifiers.identifier Types.option, 'a) Types.prod + +val instruction_matches_identifier : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj -> Bool.bool + +val does_not_occur : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj List.list -> Bool.bool + +val occurs_exactly_once : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj List.list -> Bool.bool + +val index_of_internal : + ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat -> Nat.nat + +val index_of : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat + +val index_of_label : + PreIdentifiers.identifierTag -> PreIdentifiers.identifier -> 'a1 + labelled_obj List.list -> Nat.nat + diff --git a/extracted/linearise.ml b/extracted/linearise.ml new file mode 100644 index 0000000..411f1bc --- /dev/null +++ b/extracted/linearise.ml @@ -0,0 +1,339 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +(** val graph_to_lin_statement : + Joint.uns_params -> AST.ident List.list -> 'a1 Identifiers.identifier_map + -> Joint.joint_statement -> Joint.joint_statement **) +let graph_to_lin_statement p globals visited = function +| Joint.Sequential (c, nxt) -> + (match c with + | Joint.COST_LABEL x -> Joint.Sequential (c, (Obj.magic Types.It)) + | Joint.CALL (x, x0, x1) -> Joint.Sequential (c, (Obj.magic Types.It)) + | Joint.COND (a, ltrue) -> + (match Identifiers.member PreIdentifiers.LabelTag visited + (Obj.magic nxt) with + | Bool.True -> Joint.FCOND (a, ltrue, (Obj.magic nxt)) + | Bool.False -> Joint.Sequential (c, (Obj.magic Types.It))) + | Joint.Step_seq x -> Joint.Sequential (c, (Obj.magic Types.It))) +| Joint.Final c -> Joint.Final c +| Joint.FCOND (x, x0, x1) -> assert false (* absurd case *) + +(** val chop : + ('a1 -> Bool.bool) -> 'a1 List.list -> ('a1, 'a1 List.list) Types.prod + Types.option **) +let rec chop test = function +| List.Nil -> Types.None +| List.Cons (x, l') -> + (match test x with + | Bool.True -> chop test l' + | Bool.False -> + Obj.magic + (Monad.m_return0 (Monad.max_def Option.option) { Types.fst = x; + Types.snd = l' })) + +type graph_visit_ret_type = + ((Nat.nat Identifiers.identifier_map, Identifiers.identifier_set) + Types.prod, __) Types.prod Types.sig0 + +(** val graph_visit : + Joint.uns_params -> AST.ident List.list -> __ -> + Identifiers.identifier_set -> Nat.nat Identifiers.identifier_map -> __ -> + Graphs.label List.list -> Nat.nat -> Nat.nat -> Graphs.label -> + graph_visit_ret_type **) +let rec graph_visit p globals g required visited generated visiting gen_length n entry = + (match chop (fun x -> Identifiers.member PreIdentifiers.LabelTag visited x) + visiting with + | Types.None -> + (fun _ -> { Types.fst = { Types.fst = visited; Types.snd = required }; + Types.snd = generated }) + | Types.Some pr -> + (fun _ -> + let vis_hd = pr.Types.fst in + let vis_tl = pr.Types.snd in + (match n with + | Nat.O -> (fun _ -> assert false (* absurd case *)) + | Nat.S n' -> + (fun _ -> + let visited' = + Identifiers.add PreIdentifiers.LabelTag visited vis_hd + gen_length + in + let statement = + Identifiers.lookup_safe PreIdentifiers.LabelTag (Obj.magic g) + vis_hd + in + let translated_statement = + graph_to_lin_statement p globals visited' statement + in + let generated' = List.Cons ({ Types.fst = (Types.Some vis_hd); + Types.snd = translated_statement }, (Obj.magic generated)) + in + let required' = + Identifiers.union_set PreIdentifiers.LabelTag + (Identifiers.set_from_list PreIdentifiers.LabelTag + (Joint.stmt_explicit_labels (Joint.lp_to_p__o__stmt_pars p) + globals translated_statement)) required + in + let visiting' = + List.append + (Joint.stmt_labels { Joint.uns_pars = (Joint.g_u_pars p); + Joint.succ_label = (Obj.magic (fun x -> Types.Some x)); + Joint.has_fcond = Bool.False } globals statement) vis_tl + in + let add_req_gen = + match statement with + | Joint.Sequential (s, nxt) -> + (match s with + | Joint.COST_LABEL x -> + (match Identifiers.member PreIdentifiers.LabelTag visited' + (Obj.magic nxt) with + | Bool.True -> + { Types.fst = { Types.fst = (Nat.S Nat.O); Types.snd = + (Identifiers.add_set PreIdentifiers.LabelTag + (Identifiers.empty_set PreIdentifiers.LabelTag) + (Obj.magic nxt)) }; Types.snd = (List.Cons + ({ Types.fst = Types.None; Types.snd = + (let x0 = Joint.Final (Joint.GOTO (Obj.magic nxt)) in + x0) }, List.Nil)) } + | Bool.False -> + { Types.fst = { Types.fst = Nat.O; Types.snd = + (Identifiers.empty_set PreIdentifiers.LabelTag) }; + Types.snd = List.Nil }) + | Joint.CALL (x, x0, x1) -> + (match Identifiers.member PreIdentifiers.LabelTag visited' + (Obj.magic nxt) with + | Bool.True -> + { Types.fst = { Types.fst = (Nat.S Nat.O); Types.snd = + (Identifiers.add_set PreIdentifiers.LabelTag + (Identifiers.empty_set PreIdentifiers.LabelTag) + (Obj.magic nxt)) }; Types.snd = (List.Cons + ({ Types.fst = Types.None; Types.snd = + (let x2 = Joint.Final (Joint.GOTO (Obj.magic nxt)) in + x2) }, List.Nil)) } + | Bool.False -> + { Types.fst = { Types.fst = Nat.O; Types.snd = + (Identifiers.empty_set PreIdentifiers.LabelTag) }; + Types.snd = List.Nil }) + | Joint.COND (x, x0) -> + { Types.fst = { Types.fst = Nat.O; Types.snd = + (Identifiers.empty_set PreIdentifiers.LabelTag) }; + Types.snd = List.Nil } + | Joint.Step_seq x -> + (match Identifiers.member PreIdentifiers.LabelTag visited' + (Obj.magic nxt) with + | Bool.True -> + { Types.fst = { Types.fst = (Nat.S Nat.O); Types.snd = + (Identifiers.add_set PreIdentifiers.LabelTag + (Identifiers.empty_set PreIdentifiers.LabelTag) + (Obj.magic nxt)) }; Types.snd = (List.Cons + ({ Types.fst = Types.None; Types.snd = + (let x0 = Joint.Final (Joint.GOTO (Obj.magic nxt)) in + x0) }, List.Nil)) } + | Bool.False -> + { Types.fst = { Types.fst = Nat.O; Types.snd = + (Identifiers.empty_set PreIdentifiers.LabelTag) }; + Types.snd = List.Nil })) + | Joint.Final x -> + { Types.fst = { Types.fst = Nat.O; Types.snd = + (Identifiers.empty_set PreIdentifiers.LabelTag) }; + Types.snd = List.Nil } + | Joint.FCOND (x0, x1, x2) -> + { Types.fst = { Types.fst = Nat.O; Types.snd = + (Identifiers.empty_set PreIdentifiers.LabelTag) }; + Types.snd = List.Nil } + in + graph_visit p globals g + (Identifiers.union_set PreIdentifiers.LabelTag + add_req_gen.Types.fst.Types.snd required') visited' + (Obj.magic (List.append add_req_gen.Types.snd generated')) + visiting' + (Nat.plus add_req_gen.Types.fst.Types.fst (Nat.S gen_length)) + n' entry)) __)) __ + +(** val branch_compress : + Joint.graph_params -> AST.ident List.list -> __ -> Graphs.label + Types.sig0 -> __ **) +let branch_compress p globals g entry = + g + +(** val filter_labels : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier -> Bool.bool) + -> 'a1 LabelledObjects.labelled_obj List.list -> (__, 'a1) Types.prod + List.list **) +let filter_labels tag test c = + List.map (fun s -> + let { Types.fst = l_opt; Types.snd = x } = s in + { Types.fst = + (Monad.m_bind0 (Monad.max_def Option.option) l_opt (fun l -> + match test l with + | Bool.True -> Monad.m_return0 (Monad.max_def Option.option) l + | Bool.False -> Obj.magic Types.None)); Types.snd = x }) (Obj.magic c) + +(** val linearise_code : + Joint.uns_params -> AST.ident List.list -> __ -> Graphs.label Types.sig0 + -> (__, Graphs.label -> Nat.nat Types.option) Types.prod Types.sig0 **) +let linearise_code p globals g entry_sig = + let g0 = branch_compress p globals g entry_sig in + let triple = + graph_visit p globals g0 (Identifiers.empty_set PreIdentifiers.LabelTag) + (Identifiers.empty_map PreIdentifiers.LabelTag) (Obj.magic List.Nil) + (List.Cons ((Types.pi1 entry_sig), List.Nil)) Nat.O + (Identifiers.id_map_size PreIdentifiers.LabelTag (Obj.magic g0)) + (Types.pi1 entry_sig) + in + let sigma = triple.Types.fst.Types.fst in + let required = triple.Types.fst.Types.snd in + let crev = triple.Types.snd in + let lbld_code = Util.rev (Obj.magic crev) in + { Types.fst = + (Obj.magic + (filter_labels PreIdentifiers.LabelTag (fun l -> + Identifiers.member PreIdentifiers.LabelTag required l) lbld_code)); + Types.snd = (Identifiers.lookup PreIdentifiers.LabelTag sigma) } + +(** val linearise_int_fun : + Joint.uns_params -> AST.ident List.list -> + Joint.joint_closed_internal_function -> + (Joint.joint_closed_internal_function, Graphs.label -> Nat.nat + Types.option) Types.prod Types.sig0 **) +let linearise_int_fun p globals f_sig = + let code_sigma = + linearise_code p globals (Types.pi1 f_sig).Joint.joint_if_code + (Obj.magic (Types.pi1 f_sig).Joint.joint_if_entry) + in + let code = (Types.pi1 code_sigma).Types.fst in + let sigma = (Types.pi1 code_sigma).Types.snd in + { Types.fst = { Joint.joint_if_luniverse = + (Types.pi1 f_sig).Joint.joint_if_luniverse; Joint.joint_if_runiverse = + (Types.pi1 f_sig).Joint.joint_if_runiverse; Joint.joint_if_result = + (Types.pi1 f_sig).Joint.joint_if_result; Joint.joint_if_params = + (Types.pi1 f_sig).Joint.joint_if_params; Joint.joint_if_stacksize = + (Types.pi1 f_sig).Joint.joint_if_stacksize; + Joint.joint_if_local_stacksize = + (Types.pi1 f_sig).Joint.joint_if_local_stacksize; Joint.joint_if_code = + code; Joint.joint_if_entry = (Obj.magic Nat.O) }; Types.snd = sigma } + +(** val linearise : + Joint.uns_params -> Joint.joint_program -> Joint.joint_program **) +let linearise p pr = + Joint.transform_joint_program (Joint.graph_params_to_params p) + (Joint.lin_params_to_params p) (fun globals f_in -> + (Types.pi1 (linearise_int_fun p globals f_in)).Types.fst) pr + diff --git a/extracted/linearise.mli b/extracted/linearise.mli new file mode 100644 index 0000000..8fae11a --- /dev/null +++ b/extracted/linearise.mli @@ -0,0 +1,159 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +val graph_to_lin_statement : + Joint.uns_params -> AST.ident List.list -> 'a1 Identifiers.identifier_map + -> Joint.joint_statement -> Joint.joint_statement + +val chop : + ('a1 -> Bool.bool) -> 'a1 List.list -> ('a1, 'a1 List.list) Types.prod + Types.option + +type graph_visit_ret_type = + ((Nat.nat Identifiers.identifier_map, Identifiers.identifier_set) + Types.prod, __) Types.prod Types.sig0 + +val graph_visit : + Joint.uns_params -> AST.ident List.list -> __ -> Identifiers.identifier_set + -> Nat.nat Identifiers.identifier_map -> __ -> Graphs.label List.list -> + Nat.nat -> Nat.nat -> Graphs.label -> graph_visit_ret_type + +val branch_compress : + Joint.graph_params -> AST.ident List.list -> __ -> Graphs.label Types.sig0 + -> __ + +val filter_labels : + PreIdentifiers.identifierTag -> (PreIdentifiers.identifier -> Bool.bool) -> + 'a1 LabelledObjects.labelled_obj List.list -> (__, 'a1) Types.prod + List.list + +val linearise_code : + Joint.uns_params -> AST.ident List.list -> __ -> Graphs.label Types.sig0 -> + (__, Graphs.label -> Nat.nat Types.option) Types.prod Types.sig0 + +val linearise_int_fun : + Joint.uns_params -> AST.ident List.list -> + Joint.joint_closed_internal_function -> + (Joint.joint_closed_internal_function, Graphs.label -> Nat.nat + Types.option) Types.prod Types.sig0 + +val linearise : + Joint.uns_params -> Joint.joint_program -> Joint.joint_program + diff --git a/extracted/list.ml b/extracted/list.ml new file mode 100644 index 0000000..49446e0 --- /dev/null +++ b/extracted/list.ml @@ -0,0 +1,319 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +type 'a list = +| Nil +| Cons of 'a * 'a list + +(** val list_rect_Type4 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 **) +let rec list_rect_Type4 h_nil h_cons = function +| Nil -> h_nil +| Cons (x_723, x_722) -> + h_cons x_723 x_722 (list_rect_Type4 h_nil h_cons x_722) + +(** val list_rect_Type3 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 **) +let rec list_rect_Type3 h_nil h_cons = function +| Nil -> h_nil +| Cons (x_733, x_732) -> + h_cons x_733 x_732 (list_rect_Type3 h_nil h_cons x_732) + +(** val list_rect_Type2 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 **) +let rec list_rect_Type2 h_nil h_cons = function +| Nil -> h_nil +| Cons (x_738, x_737) -> + h_cons x_738 x_737 (list_rect_Type2 h_nil h_cons x_737) + +(** val list_rect_Type1 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 **) +let rec list_rect_Type1 h_nil h_cons = function +| Nil -> h_nil +| Cons (x_743, x_742) -> + h_cons x_743 x_742 (list_rect_Type1 h_nil h_cons x_742) + +(** val list_rect_Type0 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 **) +let rec list_rect_Type0 h_nil h_cons = function +| Nil -> h_nil +| Cons (x_748, x_747) -> + h_cons x_748 x_747 (list_rect_Type0 h_nil h_cons x_747) + +(** val list_inv_rect_Type4 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) + -> 'a2 **) +let list_inv_rect_Type4 hterm h1 h2 = + let hcut = list_rect_Type4 h1 h2 hterm in hcut __ + +(** val list_inv_rect_Type3 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) + -> 'a2 **) +let list_inv_rect_Type3 hterm h1 h2 = + let hcut = list_rect_Type3 h1 h2 hterm in hcut __ + +(** val list_inv_rect_Type2 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) + -> 'a2 **) +let list_inv_rect_Type2 hterm h1 h2 = + let hcut = list_rect_Type2 h1 h2 hterm in hcut __ + +(** val list_inv_rect_Type1 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) + -> 'a2 **) +let list_inv_rect_Type1 hterm h1 h2 = + let hcut = list_rect_Type1 h1 h2 hterm in hcut __ + +(** val list_inv_rect_Type0 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) + -> 'a2 **) +let list_inv_rect_Type0 hterm h1 h2 = + let hcut = list_rect_Type0 h1 h2 hterm in hcut __ + +(** val list_discr : 'a1 list -> 'a1 list -> __ **) +let list_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Nil -> Obj.magic (fun _ dH -> dH) + | Cons (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val append : 'a1 list -> 'a1 list -> 'a1 list **) +let rec append l1 l2 = + match l1 with + | Nil -> l2 + | Cons (hd, tl) -> Cons (hd, (append tl l2)) + +(** val hd : 'a1 list -> 'a1 -> 'a1 **) +let hd l d = + match l with + | Nil -> d + | Cons (a, x) -> a + +(** val tail : 'a1 list -> 'a1 list **) +let tail = function +| Nil -> Nil +| Cons (hd0, tl) -> tl + +(** val option_hd : 'a1 list -> 'a1 Types.option **) +let option_hd = function +| Nil -> Types.None +| Cons (a, x) -> Types.Some a + +(** val option_cons : 'a1 Types.option -> 'a1 list -> 'a1 list **) +let option_cons c l = + match c with + | Types.None -> l + | Types.Some c0 -> Cons (c0, l) + +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) +let rec map f = function +| Nil -> Nil +| Cons (x, tl) -> Cons ((f x), (map f tl)) + +(** val foldr : ('a1 -> 'a2 -> 'a2) -> 'a2 -> 'a1 list -> 'a2 **) +let rec foldr f b = function +| Nil -> b +| Cons (a, l0) -> f a (foldr f b l0) + +(** val filter : ('a1 -> Bool.bool) -> 'a1 list -> 'a1 list **) +let filter p = + foldr (fun x l0 -> + match p x with + | Bool.True -> Cons (x, l0) + | Bool.False -> l0) Nil + +(** val compose : ('a1 -> 'a2 -> 'a3) -> 'a1 list -> 'a2 list -> 'a3 list **) +let compose f l1 l2 = + foldr (fun i acc -> append (map (f i) l2) acc) Nil l1 + +(** val rev_append : 'a1 list -> 'a1 list -> 'a1 list **) +let rec rev_append l1 l2 = + match l1 with + | Nil -> l2 + | Cons (a, tl) -> rev_append tl (Cons (a, l2)) + +(** val reverse : 'a1 list -> 'a1 list **) +let reverse l = + rev_append l Nil + +(** val length : 'a1 list -> Nat.nat **) +let rec length = function +| Nil -> Nat.O +| Cons (a, tl) -> Nat.S (length tl) + +(** val split_rev : + 'a1 list -> 'a1 list -> Nat.nat -> ('a1 list, 'a1 list) Types.prod **) +let rec split_rev l acc = function +| Nat.O -> { Types.fst = acc; Types.snd = l } +| Nat.S m -> + (match l with + | Nil -> { Types.fst = acc; Types.snd = Nil } + | Cons (a, tl) -> split_rev tl (Cons (a, acc)) m) + +(** val split : 'a1 list -> Nat.nat -> ('a1 list, 'a1 list) Types.prod **) +let split l n = + let { Types.fst = l1; Types.snd = l2 } = split_rev l Nil n in + { Types.fst = (reverse l1); Types.snd = l2 } + +(** val flatten : 'a1 list list -> 'a1 list **) +let flatten l = + foldr append Nil l + +(** val nth : Nat.nat -> 'a1 list -> 'a1 -> 'a1 **) +let rec nth n l d = + match n with + | Nat.O -> hd l d + | Nat.S m -> nth m (tail l) d + +(** val nth_opt : Nat.nat -> 'a1 list -> 'a1 Types.option **) +let rec nth_opt n = function +| Nil -> Types.None +| Cons (h, t) -> + (match n with + | Nat.O -> Types.Some h + | Nat.S m -> nth_opt m t) + +(** val fold : + ('a2 -> 'a2 -> 'a2) -> 'a2 -> ('a1 -> Bool.bool) -> ('a1 -> 'a2) -> 'a1 + list -> 'a2 **) +let rec fold op b p f = function +| Nil -> b +| Cons (a, l0) -> + (match p a with + | Bool.True -> op (f a) (fold op b p f l0) + | Bool.False -> fold op b p f l0) + +type 'a aop = + 'a -> 'a -> 'a + (* singleton inductive, whose constructor was mk_Aop *) + +(** val aop_rect_Type4 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type4 nil h_mk_Aop x_783 = + let op = x_783 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type5 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type5 nil h_mk_Aop x_785 = + let op = x_785 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type3 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type3 nil h_mk_Aop x_787 = + let op = x_787 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type2 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type2 nil h_mk_Aop x_789 = + let op = x_789 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type1 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type1 nil h_mk_Aop x_791 = + let op = x_791 in h_mk_Aop op __ __ __ + +(** val aop_rect_Type0 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 **) +let rec aop_rect_Type0 nil h_mk_Aop x_793 = + let op = x_793 in h_mk_Aop op __ __ __ + +(** val op : 'a1 -> 'a1 aop -> 'a1 -> 'a1 -> 'a1 **) +let rec op nil xxx = + let yyy = xxx in yyy + +(** val aop_inv_rect_Type4 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type4 x2 hterm h1 = + let hcut = aop_rect_Type4 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type3 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type3 x2 hterm h1 = + let hcut = aop_rect_Type3 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type2 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type2 x2 hterm h1 = + let hcut = aop_rect_Type2 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type1 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type1 x2 hterm h1 = + let hcut = aop_rect_Type1 x2 h1 hterm in hcut __ + +(** val aop_inv_rect_Type0 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 **) +let aop_inv_rect_Type0 x2 hterm h1 = + let hcut = aop_rect_Type0 x2 h1 hterm in hcut __ + +(** val aop_discr : 'a1 -> 'a1 aop -> 'a1 aop -> __ **) +let aop_discr a2 x y = + Logic.eq_rect_Type2 x + (let a0 = x in Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val dpi1__o__op : + 'a1 -> ('a1 aop, 'a2) Types.dPair -> 'a1 -> 'a1 -> 'a1 **) +let dpi1__o__op x1 x3 = + op x1 x3.Types.dpi1 + +(** val lhd : 'a1 list -> Nat.nat -> 'a1 list **) +let rec lhd l = function +| Nat.O -> Nil +| Nat.S n0 -> + (match l with + | Nil -> Nil + | Cons (a, l0) -> Cons (a, (lhd l0 n0))) + +(** val ltl : 'a1 list -> Nat.nat -> 'a1 list **) +let rec ltl l = function +| Nat.O -> l +| Nat.S n0 -> ltl (tail l) n0 + +(** val find : ('a1 -> 'a2 Types.option) -> 'a1 list -> 'a2 Types.option **) +let rec find f = function +| Nil -> Types.None +| Cons (h, t) -> + (match f h with + | Types.None -> find f t + | Types.Some b -> Types.Some b) + +(** val position_of_aux : + ('a1 -> Bool.bool) -> 'a1 list -> Nat.nat -> Nat.nat Types.option **) +let rec position_of_aux found l acc = + match l with + | Nil -> Types.None + | Cons (h, t) -> + (match found h with + | Bool.True -> Types.Some acc + | Bool.False -> position_of_aux found t (Nat.S acc)) + +(** val position_of : + ('a1 -> Bool.bool) -> 'a1 list -> Nat.nat Types.option **) +let position_of found l = + position_of_aux found l Nat.O + +(** val make_list : 'a1 -> Nat.nat -> 'a1 list **) +let rec make_list a = function +| Nat.O -> Nil +| Nat.S m -> Cons (a, (make_list a m)) + diff --git a/extracted/list.mli b/extracted/list.mli new file mode 100644 index 0000000..a264336 --- /dev/null +++ b/extracted/list.mli @@ -0,0 +1,159 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +type 'a list = +| Nil +| Cons of 'a * 'a list + +val list_rect_Type4 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 + +val list_rect_Type3 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 + +val list_rect_Type2 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 + +val list_rect_Type1 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 + +val list_rect_Type0 : + 'a2 -> ('a1 -> 'a1 list -> 'a2 -> 'a2) -> 'a1 list -> 'a2 + +val list_inv_rect_Type4 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) -> + 'a2 + +val list_inv_rect_Type3 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) -> + 'a2 + +val list_inv_rect_Type2 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) -> + 'a2 + +val list_inv_rect_Type1 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) -> + 'a2 + +val list_inv_rect_Type0 : + 'a1 list -> (__ -> 'a2) -> ('a1 -> 'a1 list -> (__ -> 'a2) -> __ -> 'a2) -> + 'a2 + +val list_discr : 'a1 list -> 'a1 list -> __ + +val append : 'a1 list -> 'a1 list -> 'a1 list + +val hd : 'a1 list -> 'a1 -> 'a1 + +val tail : 'a1 list -> 'a1 list + +val option_hd : 'a1 list -> 'a1 Types.option + +val option_cons : 'a1 Types.option -> 'a1 list -> 'a1 list + +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list + +val foldr : ('a1 -> 'a2 -> 'a2) -> 'a2 -> 'a1 list -> 'a2 + +val filter : ('a1 -> Bool.bool) -> 'a1 list -> 'a1 list + +val compose : ('a1 -> 'a2 -> 'a3) -> 'a1 list -> 'a2 list -> 'a3 list + +val rev_append : 'a1 list -> 'a1 list -> 'a1 list + +val reverse : 'a1 list -> 'a1 list + +val length : 'a1 list -> Nat.nat + +val split_rev : + 'a1 list -> 'a1 list -> Nat.nat -> ('a1 list, 'a1 list) Types.prod + +val split : 'a1 list -> Nat.nat -> ('a1 list, 'a1 list) Types.prod + +val flatten : 'a1 list list -> 'a1 list + +val nth : Nat.nat -> 'a1 list -> 'a1 -> 'a1 + +val nth_opt : Nat.nat -> 'a1 list -> 'a1 Types.option + +val fold : + ('a2 -> 'a2 -> 'a2) -> 'a2 -> ('a1 -> Bool.bool) -> ('a1 -> 'a2) -> 'a1 + list -> 'a2 + +type 'a aop = + 'a -> 'a -> 'a + (* singleton inductive, whose constructor was mk_Aop *) + +val aop_rect_Type4 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type5 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type3 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type2 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type1 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val aop_rect_Type0 : + 'a1 -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> 'a2) -> 'a1 aop -> 'a2 + +val op : 'a1 -> 'a1 aop -> 'a1 -> 'a1 -> 'a1 + +val aop_inv_rect_Type4 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type3 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type2 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type1 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_inv_rect_Type0 : + 'a1 -> 'a1 aop -> (('a1 -> 'a1 -> 'a1) -> __ -> __ -> __ -> __ -> 'a2) -> + 'a2 + +val aop_discr : 'a1 -> 'a1 aop -> 'a1 aop -> __ + +val dpi1__o__op : 'a1 -> ('a1 aop, 'a2) Types.dPair -> 'a1 -> 'a1 -> 'a1 + +val lhd : 'a1 list -> Nat.nat -> 'a1 list + +val ltl : 'a1 list -> Nat.nat -> 'a1 list + +val find : ('a1 -> 'a2 Types.option) -> 'a1 list -> 'a2 Types.option + +val position_of_aux : + ('a1 -> Bool.bool) -> 'a1 list -> Nat.nat -> Nat.nat Types.option + +val position_of : ('a1 -> Bool.bool) -> 'a1 list -> Nat.nat Types.option + +val make_list : 'a1 -> Nat.nat -> 'a1 list + diff --git a/extracted/listb.ml b/extracted/listb.ml new file mode 100644 index 0000000..26a393f --- /dev/null +++ b/extracted/listb.ml @@ -0,0 +1,55 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Sets + +open Deqsets + +(** val isnilb : 'a1 List.list -> Bool.bool **) +let rec isnilb = function +| List.Nil -> Bool.True +| List.Cons (hd0, tl) -> Bool.False + +(** val memb : Deqsets.deqSet -> __ -> __ List.list -> Bool.bool **) +let rec memb s x = function +| List.Nil -> Bool.False +| List.Cons (a, tl) -> Bool.orb (Deqsets.eqb s x a) (memb s x tl) + +(** val uniqueb : Deqsets.deqSet -> __ List.list -> Bool.bool **) +let rec uniqueb s = function +| List.Nil -> Bool.True +| List.Cons (a, tl) -> Bool.andb (Bool.notb (memb s a tl)) (uniqueb s tl) + +(** val unique_append : + Deqsets.deqSet -> __ List.list -> __ List.list -> __ List.list **) +let rec unique_append s l1 l2 = + match l1 with + | List.Nil -> l2 + | List.Cons (a, tl) -> + let r = unique_append s tl l2 in + (match memb s a r with + | Bool.True -> r + | Bool.False -> List.Cons (a, r)) + +(** val exists : ('a1 -> Bool.bool) -> 'a1 List.list -> Bool.bool **) +let rec exists p = function +| List.Nil -> Bool.False +| List.Cons (h, t) -> Bool.orb (p h) (exists p t) + diff --git a/extracted/listb.mli b/extracted/listb.mli new file mode 100644 index 0000000..7d964ef --- /dev/null +++ b/extracted/listb.mli @@ -0,0 +1,35 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Sets + +open Deqsets + +val isnilb : 'a1 List.list -> Bool.bool + +val memb : Deqsets.deqSet -> __ -> __ List.list -> Bool.bool + +val uniqueb : Deqsets.deqSet -> __ List.list -> Bool.bool + +val unique_append : + Deqsets.deqSet -> __ List.list -> __ List.list -> __ List.list + +val exists : ('a1 -> Bool.bool) -> 'a1 List.list -> Bool.bool + diff --git a/extracted/listb_extra.ml b/extracted/listb_extra.ml new file mode 100644 index 0000000..91a1263 --- /dev/null +++ b/extracted/listb_extra.ml @@ -0,0 +1,42 @@ +open Preamble + +open Deqsets + +open Sets + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Listb + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Setoids + +open Monad + +open Option + +open Lists + diff --git a/extracted/listb_extra.mli b/extracted/listb_extra.mli new file mode 100644 index 0000000..91a1263 --- /dev/null +++ b/extracted/listb_extra.mli @@ -0,0 +1,42 @@ +open Preamble + +open Deqsets + +open Sets + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Listb + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Setoids + +open Monad + +open Option + +open Lists + diff --git a/extracted/lists.ml b/extracted/lists.ml new file mode 100644 index 0000000..ad0d508 --- /dev/null +++ b/extracted/lists.ml @@ -0,0 +1,100 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +(** val all : ('a1 -> Bool.bool) -> 'a1 List.list -> Bool.bool **) +let rec all p = function +| List.Nil -> Bool.True +| List.Cons (h, t) -> Bool.andb (p h) (all p t) + +(** val map_All : ('a1 -> __ -> 'a2) -> 'a1 List.list -> 'a2 List.list **) +let rec map_All f l = + (match l with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (hd, tl) -> (fun _ -> List.Cons ((f hd __), (map_All f tl)))) + __ + +open Setoids + +open Monad + +open Option + +(** val append : 'a1 List.list List.aop **) +let append = + List.append + +(** val list : Monad.monadProps **) +let list = + Monad.makeMonadProps (fun _ x -> List.Cons (x, List.Nil)) (fun _ _ l f -> + List.foldr (fun x -> List.append (f x)) List.Nil l) + +(** val count : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat **) +let rec count f = function +| List.Nil -> Nat.O +| List.Cons (x, l') -> + Nat.plus + (match f x with + | Bool.True -> Nat.S Nat.O + | Bool.False -> Nat.O) (count f l') + +(** val position_of_safe : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat **) +let position_of_safe test l = + Option.opt_safe (List.position_of test l) + +(** val index_of : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat **) +let index_of test l = + position_of_safe test l + +(** val ordered_insert : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 -> 'a1 List.list -> 'a1 List.list **) +let rec ordered_insert lt a = function +| List.Nil -> List.Cons (a, List.Nil) +| List.Cons (h, t) -> + (match lt a h with + | Bool.True -> List.Cons (a, (List.Cons (h, t))) + | Bool.False -> List.Cons (h, (ordered_insert lt a t))) + +(** val insert_sort : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 List.list -> 'a1 List.list **) +let rec insert_sort lt = function +| List.Nil -> List.Nil +| List.Cons (h, t) -> ordered_insert lt h (insert_sort lt t) + +(** val range_strong_internal : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat Types.sig0 List.list **) +let rec range_strong_internal index how_many end0 = + (match how_many with + | Nat.O -> (fun _ -> List.Nil) + | Nat.S k -> + (fun _ -> List.Cons (index, + (range_strong_internal (Nat.S index) k end0)))) __ + +(** val range_strong : Nat.nat -> Nat.nat Types.sig0 List.list **) +let range_strong end0 = + range_strong_internal Nat.O end0 end0 + diff --git a/extracted/lists.mli b/extracted/lists.mli new file mode 100644 index 0000000..ba33bae --- /dev/null +++ b/extracted/lists.mli @@ -0,0 +1,58 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +val all : ('a1 -> Bool.bool) -> 'a1 List.list -> Bool.bool + +val map_All : ('a1 -> __ -> 'a2) -> 'a1 List.list -> 'a2 List.list + +open Setoids + +open Monad + +open Option + +val append : 'a1 List.list List.aop + +val list : Monad.monadProps + +val count : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat + +val position_of_safe : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat + +val index_of : ('a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat + +val ordered_insert : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 -> 'a1 List.list -> 'a1 List.list + +val insert_sort : ('a1 -> 'a1 -> Bool.bool) -> 'a1 List.list -> 'a1 List.list + +val range_strong_internal : + Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat Types.sig0 List.list + +val range_strong : Nat.nat -> Nat.nat Types.sig0 List.list + diff --git a/extracted/liveness.ml b/extracted/liveness.ml new file mode 100644 index 0000000..a1108f0 --- /dev/null +++ b/extracted/liveness.ml @@ -0,0 +1,470 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open ERTL + +open Set_adt + +open Fixpoints + +(** val rl_included : + (PreIdentifiers.identifier Set_adt.set, I8051.register Set_adt.set) + Types.prod -> (PreIdentifiers.identifier Set_adt.set, I8051.register + Set_adt.set) Types.prod -> Bool.bool **) +let rl_included left right = + Bool.andb + (Set_adt.set_subset + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) left.Types.fst + right.Types.fst) + (Set_adt.set_subset I8051.eq_Register left.Types.snd right.Types.snd) + +(** val register_lattice : Fixpoints.property_lattice **) +let register_lattice = + { Fixpoints.l_bottom = + (Obj.magic { Types.fst = Set_adt.set_empty; Types.snd = + Set_adt.set_empty }); Fixpoints.l_equal = (fun left right -> + Bool.andb + (Set_adt.set_equal + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic left).Types.fst (Obj.magic right).Types.fst) + (Set_adt.set_equal I8051.eq_Register (Obj.magic left).Types.snd + (Obj.magic right).Types.snd)); Fixpoints.l_included = + (Obj.magic rl_included); Fixpoints.l_is_maximal = (fun x -> Bool.False) } + +(** val rl_bottom : __ **) +let rl_bottom = + register_lattice.Fixpoints.l_bottom + +(** val rl_psingleton : Registers.register -> __ **) +let rl_psingleton r = + Obj.magic { Types.fst = (Set_adt.set_singleton r); Types.snd = + Set_adt.set_empty } + +(** val rl_hsingleton : I8051.register -> __ **) +let rl_hsingleton r = + Obj.magic { Types.fst = Set_adt.set_empty; Types.snd = + (Set_adt.set_singleton r) } + +(** val pairwise : + ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a2 -> 'a2) -> ('a1, 'a2) Types.prod -> + ('a1, 'a2) Types.prod -> ('a1, 'a2) Types.prod **) +let pairwise f g c1 c2 = + { Types.fst = (f c1.Types.fst c2.Types.fst); Types.snd = + (g c1.Types.snd c2.Types.snd) } + +(** val rl_join : __ -> __ -> __ **) +let rl_join = + Obj.magic (pairwise Set_adt.set_union Set_adt.set_union) + +(** val rl_diff : __ -> __ -> __ **) +let rl_diff = + Obj.magic (pairwise Set_adt.set_diff Set_adt.set_diff) + +(** val defined : AST.ident List.list -> Joint.joint_statement -> __ **) +let defined globals = function +| Joint.Sequential (seq, l) -> + (match seq with + | Joint.COST_LABEL clabel -> rl_bottom + | Joint.CALL (x, x0, x1) -> + Obj.magic { Types.fst = Set_adt.set_empty; Types.snd = + (Set_adt.set_from_list I8051.registerCallerSaved) } + | Joint.COND (r, lbl_true) -> rl_bottom + | Joint.Step_seq s0 -> + (match s0 with + | Joint.COMMENT c -> rl_bottom + | Joint.MOVE pair_reg -> + (match (Obj.magic pair_reg).Types.fst with + | ERTL.PSD p -> rl_psingleton p + | ERTL.HDW h -> rl_hsingleton h) + | Joint.POP r -> rl_psingleton (Obj.magic r) + | Joint.PUSH r -> rl_bottom + | Joint.ADDRESS (x, x1, r1, r2) -> + rl_join (rl_psingleton (Obj.magic r1)) (rl_psingleton (Obj.magic r2)) + | Joint.OPACCS (opaccs, dr1, dr2, sr1, sr2) -> + rl_join + (rl_join (rl_psingleton (Obj.magic dr1)) + (rl_psingleton (Obj.magic dr2))) + (rl_hsingleton I8051.RegisterCarry) + | Joint.OP1 (op1, r1, r2) -> rl_psingleton (Obj.magic r1) + | Joint.OP2 (op2, r1, r2, x) -> + (match op2 with + | BackEndOps.Add -> + rl_join (rl_hsingleton I8051.RegisterCarry) + (rl_psingleton (Obj.magic r1)) + | BackEndOps.Addc -> + rl_join (rl_hsingleton I8051.RegisterCarry) + (rl_psingleton (Obj.magic r1)) + | BackEndOps.Sub -> + rl_join (rl_hsingleton I8051.RegisterCarry) + (rl_psingleton (Obj.magic r1)) + | BackEndOps.And -> rl_psingleton (Obj.magic r1) + | BackEndOps.Or -> rl_psingleton (Obj.magic r1) + | BackEndOps.Xor -> rl_psingleton (Obj.magic r1)) + | Joint.CLEAR_CARRY -> rl_hsingleton I8051.RegisterCarry + | Joint.SET_CARRY -> rl_hsingleton I8051.RegisterCarry + | Joint.LOAD (r, x, x0) -> rl_psingleton (Obj.magic r) + | Joint.STORE (acc_a, dpl, dph) -> rl_bottom + | Joint.Extension_seq ext -> + (match Obj.magic ext with + | ERTL.Ertl_new_frame -> + rl_join (rl_hsingleton I8051.registerSPL) + (rl_hsingleton I8051.registerSPH) + | ERTL.Ertl_del_frame -> + rl_join (rl_hsingleton I8051.registerSPL) + (rl_hsingleton I8051.registerSPH) + | ERTL.Ertl_frame_size r -> rl_psingleton r))) +| Joint.Final x -> rl_bottom +| Joint.FCOND (x, x0, x1) -> assert false (* absurd case *) + +(** val ret_regs : I8051.register Set_adt.set **) +let ret_regs = + Set_adt.set_from_list I8051.registerRets + +(** val rl_arg : Joint.psd_argument -> __ **) +let rl_arg = function +| Joint.Reg r -> rl_psingleton r +| Joint.Imm x -> rl_bottom + +(** val used : + AST.ident List.list -> Joint.joint_statement -> (Registers.register + Set_adt.set, I8051.register Set_adt.set) Types.prod **) +let used globals = function +| Joint.Sequential (seq, l) -> + (match seq with + | Joint.COST_LABEL clabel -> Obj.magic rl_bottom + | Joint.CALL (f, nparams, x) -> + Obj.magic + (rl_join + (match f with + | Types.Inl x0 -> rl_bottom + | Types.Inr pr -> + rl_join (rl_arg (Obj.magic pr).Types.fst) + (rl_arg (Obj.magic pr).Types.snd)) + (Obj.magic { Types.fst = Set_adt.set_empty; Types.snd = + (Set_adt.set_from_list + (Util.prefix (Obj.magic nparams) I8051.registerParams)) })) + | Joint.COND (r, lbl_true) -> Obj.magic (rl_psingleton (Obj.magic r)) + | Joint.Step_seq s0 -> + (match s0 with + | Joint.COMMENT x -> Obj.magic rl_bottom + | Joint.MOVE pair_reg -> + let r2 = (Obj.magic pair_reg).Types.snd in + (match r2 with + | Joint.Reg p -> + (match p with + | ERTL.PSD r -> Obj.magic (rl_psingleton r) + | ERTL.HDW r -> Obj.magic (rl_hsingleton r)) + | Joint.Imm x -> Obj.magic rl_bottom) + | Joint.POP x -> Obj.magic rl_bottom + | Joint.PUSH r -> Obj.magic (rl_arg (Obj.magic r)) + | Joint.ADDRESS (x, x1, x2, x3) -> Obj.magic rl_bottom + | Joint.OPACCS (opaccs, dr1, dr2, sr1, sr2) -> + Obj.magic (rl_join (rl_arg (Obj.magic sr1)) (rl_arg (Obj.magic sr2))) + | Joint.OP1 (op1, r1, r2) -> Obj.magic (rl_psingleton (Obj.magic r2)) + | Joint.OP2 (op2, acc_a, r1, r2) -> + Obj.magic + (rl_join (rl_join (rl_arg (Obj.magic r1)) (rl_arg (Obj.magic r2))) + (match op2 with + | BackEndOps.Add -> rl_bottom + | BackEndOps.Addc -> rl_hsingleton I8051.RegisterCarry + | BackEndOps.Sub -> rl_hsingleton I8051.RegisterCarry + | BackEndOps.And -> rl_bottom + | BackEndOps.Or -> rl_bottom + | BackEndOps.Xor -> rl_bottom)) + | Joint.CLEAR_CARRY -> Obj.magic rl_bottom + | Joint.SET_CARRY -> Obj.magic rl_bottom + | Joint.LOAD (acc_a, dpl, dph) -> + Obj.magic (rl_join (rl_arg (Obj.magic dpl)) (rl_arg (Obj.magic dph))) + | Joint.STORE (acc_a, dpl, dph) -> + Obj.magic + (rl_join + (rl_join (rl_arg (Obj.magic acc_a)) (rl_arg (Obj.magic dpl))) + (rl_arg (Obj.magic dph))) + | Joint.Extension_seq ext -> + (match Obj.magic ext with + | ERTL.Ertl_new_frame -> + Obj.magic + (rl_join (rl_hsingleton I8051.registerSPL) + (rl_hsingleton I8051.registerSPH)) + | ERTL.Ertl_del_frame -> + Obj.magic + (rl_join (rl_hsingleton I8051.registerSPL) + (rl_hsingleton I8051.registerSPH)) + | ERTL.Ertl_frame_size r -> Obj.magic rl_bottom))) +| Joint.Final fin -> + (match fin with + | Joint.GOTO l -> Obj.magic rl_bottom + | Joint.RETURN -> + { Types.fst = Set_adt.set_empty; Types.snd = + (Set_adt.set_union (Set_adt.set_from_list I8051.registerCalleeSaved) + ret_regs) } + | Joint.TAILCALL (x, x0) -> assert false (* absurd case *)) +| Joint.FCOND (x, x0, x1) -> assert false (* absurd case *) + +(** val eliminable_step : + AST.ident List.list -> __ -> Joint.joint_step -> Bool.bool **) +let eliminable_step globals l s = + let pliveafter = (Obj.magic l).Types.fst in + let hliveafter = (Obj.magic l).Types.snd in + (match s with + | Joint.COST_LABEL x -> Bool.False + | Joint.CALL (x, x0, x1) -> Bool.False + | Joint.COND (x, x0) -> Bool.False + | Joint.Step_seq s0 -> + (match s0 with + | Joint.COMMENT x -> Bool.False + | Joint.MOVE pair_reg -> + Bool.notb + (match (Obj.magic pair_reg).Types.fst with + | ERTL.PSD p1 -> + Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) p1 + pliveafter + | ERTL.HDW h1 -> + Set_adt.set_member I8051.eq_Register h1 hliveafter) + | Joint.POP x -> Bool.False + | Joint.PUSH x -> Bool.False + | Joint.ADDRESS (x, x1, r1, r2) -> + Bool.notb + (Bool.orb + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic r1) pliveafter) + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic r2) pliveafter)) + | Joint.OPACCS (opaccs, dr1, dr2, sr1, sr2) -> + Bool.notb + (Bool.orb + (Bool.orb + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic dr1) pliveafter) + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic dr2) pliveafter)) + (Set_adt.set_member I8051.eq_Register I8051.RegisterCarry + hliveafter)) + | Joint.OP1 (op1, r1, r2) -> + Bool.notb + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic r1) pliveafter) + | Joint.OP2 (op2, r1, r2, r3) -> + Bool.notb + (Bool.orb + (match op2 with + | BackEndOps.Add -> + Set_adt.set_member I8051.eq_Register I8051.RegisterCarry + hliveafter + | BackEndOps.Addc -> + Set_adt.set_member I8051.eq_Register I8051.RegisterCarry + hliveafter + | BackEndOps.Sub -> + Set_adt.set_member I8051.eq_Register I8051.RegisterCarry + hliveafter + | BackEndOps.And -> Bool.False + | BackEndOps.Or -> Bool.False + | BackEndOps.Xor -> Bool.False) + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic r1) pliveafter)) + | Joint.CLEAR_CARRY -> Bool.False + | Joint.SET_CARRY -> Bool.False + | Joint.LOAD (acc_a, dpl, dph) -> + Bool.notb + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + (Obj.magic acc_a) pliveafter) + | Joint.STORE (x, x0, x1) -> Bool.False + | Joint.Extension_seq ext -> + (match Obj.magic ext with + | ERTL.Ertl_new_frame -> Bool.False + | ERTL.Ertl_del_frame -> Bool.False + | ERTL.Ertl_frame_size r -> + Bool.notb + (Set_adt.set_member + (Identifiers.eq_identifier PreIdentifiers.RegisterTag) r + pliveafter)))) + +(** val eliminable : + AST.ident List.list -> __ -> Joint.joint_statement -> Bool.bool **) +let eliminable globals l s = + let pliveafter = (Obj.magic l).Types.fst in + let hliveafter = (Obj.magic l).Types.snd in + (match s with + | Joint.Sequential (seq, x) -> eliminable_step globals l seq + | Joint.Final x -> Bool.False + | Joint.FCOND (x0, x1, x2) -> Bool.False) + +(** val statement_semantics : + AST.ident List.list -> Joint.joint_statement -> __ -> __ **) +let statement_semantics globals stmt liveafter = + match eliminable globals liveafter stmt with + | Bool.True -> liveafter + | Bool.False -> + rl_join (rl_diff liveafter (defined globals stmt)) + (Obj.magic (used globals stmt)) + +(** val livebefore : + AST.ident List.list -> Joint.joint_internal_function -> + Fixpoints.valuation -> Fixpoints.valuation **) +let livebefore globals int_fun liveafter label = + match Identifiers.lookup PreIdentifiers.LabelTag + (Obj.magic int_fun.Joint.joint_if_code) label with + | Types.None -> rl_bottom + | Types.Some stmt -> statement_semantics globals stmt (liveafter label) + +(** val liveafter : + AST.ident List.list -> Joint.joint_internal_function -> + PreIdentifiers.identifier -> Fixpoints.valuation -> __ **) +let liveafter globals int_fun label liveafter0 = + match Identifiers.lookup PreIdentifiers.LabelTag + (Obj.magic int_fun.Joint.joint_if_code) label with + | Types.None -> rl_bottom + | Types.Some stmt -> + List.fold rl_join rl_bottom (fun successor -> Bool.True) + (fun successor -> livebefore globals int_fun liveafter0 successor) + (Joint.stmt_labels { Joint.uns_pars = (Joint.g_u_pars ERTL.eRTL); + Joint.succ_label = (Obj.magic (fun x -> Types.Some x)); + Joint.has_fcond = Bool.False } globals stmt) + +(** val analyse_liveness : + Fixpoints.fixpoint_computer -> AST.ident List.list -> + Joint.joint_internal_function -> Fixpoints.fixpoint **) +let analyse_liveness the_fixpoint globals int_fun = + the_fixpoint register_lattice (liveafter globals int_fun) + +type vertex = (Registers.register, I8051.register) Types.sum + +(** val plives : Registers.register -> __ -> Bool.bool **) +let plives vertex0 prop = + Set_adt.set_member (Identifiers.eq_identifier PreIdentifiers.RegisterTag) + vertex0 (Obj.magic prop).Types.fst + +(** val hlives : I8051.register -> __ -> Bool.bool **) +let hlives vertex0 prop = + Set_adt.set_member I8051.eq_Register vertex0 (Obj.magic prop).Types.snd + +(** val lives : vertex -> __ -> Bool.bool **) +let lives = function +| Types.Inl v -> plives v +| Types.Inr v -> hlives v + diff --git a/extracted/liveness.mli b/extracted/liveness.mli new file mode 100644 index 0000000..2cc2f07 --- /dev/null +++ b/extracted/liveness.mli @@ -0,0 +1,186 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open ERTL + +open Set_adt + +open Fixpoints + +val rl_included : + (PreIdentifiers.identifier Set_adt.set, I8051.register Set_adt.set) + Types.prod -> (PreIdentifiers.identifier Set_adt.set, I8051.register + Set_adt.set) Types.prod -> Bool.bool + +val register_lattice : Fixpoints.property_lattice + +val rl_bottom : __ + +val rl_psingleton : Registers.register -> __ + +val rl_hsingleton : I8051.register -> __ + +val pairwise : + ('a1 -> 'a1 -> 'a1) -> ('a2 -> 'a2 -> 'a2) -> ('a1, 'a2) Types.prod -> + ('a1, 'a2) Types.prod -> ('a1, 'a2) Types.prod + +val rl_join : __ -> __ -> __ + +val rl_diff : __ -> __ -> __ + +val defined : AST.ident List.list -> Joint.joint_statement -> __ + +val ret_regs : I8051.register Set_adt.set + +val rl_arg : Joint.psd_argument -> __ + +val used : + AST.ident List.list -> Joint.joint_statement -> (Registers.register + Set_adt.set, I8051.register Set_adt.set) Types.prod + +val eliminable_step : + AST.ident List.list -> __ -> Joint.joint_step -> Bool.bool + +val eliminable : + AST.ident List.list -> __ -> Joint.joint_statement -> Bool.bool + +val statement_semantics : + AST.ident List.list -> Joint.joint_statement -> __ -> __ + +val livebefore : + AST.ident List.list -> Joint.joint_internal_function -> Fixpoints.valuation + -> Fixpoints.valuation + +val liveafter : + AST.ident List.list -> Joint.joint_internal_function -> + PreIdentifiers.identifier -> Fixpoints.valuation -> __ + +val analyse_liveness : + Fixpoints.fixpoint_computer -> AST.ident List.list -> + Joint.joint_internal_function -> Fixpoints.fixpoint + +type vertex = (Registers.register, I8051.register) Types.sum + +val plives : Registers.register -> __ -> Bool.bool + +val hlives : I8051.register -> __ -> Bool.bool + +val lives : vertex -> __ -> Bool.bool + diff --git a/extracted/logic.ml b/extracted/logic.ml new file mode 100644 index 0000000..b84da4c --- /dev/null +++ b/extracted/logic.ml @@ -0,0 +1,249 @@ +open Preamble + +open Core_notation + +open Pts + +open Hints_declaration + +(** val eq_rect_Type4 : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rec eq_rect_Type4 x h_refl x_4 = + h_refl + +(** val eq_rect_Type5 : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rec eq_rect_Type5 x h_refl x_7 = + h_refl + +(** val eq_rect_Type3 : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rec eq_rect_Type3 x h_refl x_10 = + h_refl + +(** val eq_rect_Type2 : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rec eq_rect_Type2 x h_refl x_13 = + h_refl + +(** val eq_rect_Type1 : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rec eq_rect_Type1 x h_refl x_16 = + h_refl + +(** val eq_rect_Type0 : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rec eq_rect_Type0 x h_refl x_19 = + h_refl + +(** val eq_rect_r : 'a1 -> 'a1 -> 'a2 -> 'a2 **) +let eq_rect_r a x x0 = + (fun _ auto -> auto) __ x0 + +(** val eq_rect_Type0_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type0_r a h x = + (fun _ auto -> auto) __ h + +(** val eq_rect_Type1_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type1_r a h x = + (fun _ auto -> auto) __ h + +(** val eq_rect_Type2_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type2_r a h x = + (fun _ auto -> auto) __ h + +(** val eq_rect_Type3_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type3_r a h x = + (fun _ auto -> auto) __ h + +(** val rewrite_l : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rewrite_l x hx y = + hx + +(** val rewrite_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let rewrite_r x hx y = + hx + +(** val eq_coerc : 'a1 -> 'a2 **) +let eq_coerc ha = + eq_rect_Type0 __ (Obj.magic ha) __ + +(** val true_rect_Type4 : 'a1 -> 'a1 **) +let rec true_rect_Type4 h_I = + h_I + +(** val true_rect_Type5 : 'a1 -> 'a1 **) +let rec true_rect_Type5 h_I = + h_I + +(** val true_rect_Type3 : 'a1 -> 'a1 **) +let rec true_rect_Type3 h_I = + h_I + +(** val true_rect_Type2 : 'a1 -> 'a1 **) +let rec true_rect_Type2 h_I = + h_I + +(** val true_rect_Type1 : 'a1 -> 'a1 **) +let rec true_rect_Type1 h_I = + h_I + +(** val true_rect_Type0 : 'a1 -> 'a1 **) +let rec true_rect_Type0 h_I = + h_I + +(** val true_inv_rect_Type4 : (__ -> 'a1) -> 'a1 **) +let true_inv_rect_Type4 h1 = + let hcut = true_rect_Type4 h1 in hcut __ + +(** val true_inv_rect_Type3 : (__ -> 'a1) -> 'a1 **) +let true_inv_rect_Type3 h1 = + let hcut = true_rect_Type3 h1 in hcut __ + +(** val true_inv_rect_Type2 : (__ -> 'a1) -> 'a1 **) +let true_inv_rect_Type2 h1 = + let hcut = true_rect_Type2 h1 in hcut __ + +(** val true_inv_rect_Type1 : (__ -> 'a1) -> 'a1 **) +let true_inv_rect_Type1 h1 = + let hcut = true_rect_Type1 h1 in hcut __ + +(** val true_inv_rect_Type0 : (__ -> 'a1) -> 'a1 **) +let true_inv_rect_Type0 h1 = + let hcut = true_rect_Type0 h1 in hcut __ + +(** val true_discr : __ -> __ **) +let true_discr _ = + eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH)) __ + +(** val false_rect_Type4 : __ -> 'a1 **) +let rec false_rect_Type4 _ = + assert false (* absurd case *) + +(** val false_rect_Type5 : __ -> 'a1 **) +let rec false_rect_Type5 _ = + assert false (* absurd case *) + +(** val false_rect_Type3 : __ -> 'a1 **) +let rec false_rect_Type3 _ = + assert false (* absurd case *) + +(** val false_rect_Type2 : __ -> 'a1 **) +let rec false_rect_Type2 _ = + assert false (* absurd case *) + +(** val false_rect_Type1 : __ -> 'a1 **) +let rec false_rect_Type1 _ = + assert false (* absurd case *) + +(** val false_rect_Type0 : __ -> 'a1 **) +let rec false_rect_Type0 _ = + assert false (* absurd case *) + +(** val not_rect_Type4 : (__ -> 'a1) -> 'a1 **) +let rec not_rect_Type4 h_nmk = + h_nmk __ + +(** val not_rect_Type5 : (__ -> 'a1) -> 'a1 **) +let rec not_rect_Type5 h_nmk = + h_nmk __ + +(** val not_rect_Type3 : (__ -> 'a1) -> 'a1 **) +let rec not_rect_Type3 h_nmk = + h_nmk __ + +(** val not_rect_Type2 : (__ -> 'a1) -> 'a1 **) +let rec not_rect_Type2 h_nmk = + h_nmk __ + +(** val not_rect_Type1 : (__ -> 'a1) -> 'a1 **) +let rec not_rect_Type1 h_nmk = + h_nmk __ + +(** val not_rect_Type0 : (__ -> 'a1) -> 'a1 **) +let rec not_rect_Type0 h_nmk = + h_nmk __ + +(** val not_inv_rect_Type4 : (__ -> __ -> 'a1) -> 'a1 **) +let not_inv_rect_Type4 h1 = + let hcut = not_rect_Type4 h1 in hcut __ + +(** val not_inv_rect_Type3 : (__ -> __ -> 'a1) -> 'a1 **) +let not_inv_rect_Type3 h1 = + let hcut = not_rect_Type3 h1 in hcut __ + +(** val not_inv_rect_Type2 : (__ -> __ -> 'a1) -> 'a1 **) +let not_inv_rect_Type2 h1 = + let hcut = not_rect_Type2 h1 in hcut __ + +(** val not_inv_rect_Type1 : (__ -> __ -> 'a1) -> 'a1 **) +let not_inv_rect_Type1 h1 = + let hcut = not_rect_Type1 h1 in hcut __ + +(** val not_inv_rect_Type0 : (__ -> __ -> 'a1) -> 'a1 **) +let not_inv_rect_Type0 h1 = + let hcut = not_rect_Type0 h1 in hcut __ + +(** val and_rect_Type4 : (__ -> __ -> 'a1) -> 'a1 **) +let rec and_rect_Type4 h_conj = + h_conj __ __ + +(** val and_rect_Type5 : (__ -> __ -> 'a1) -> 'a1 **) +let rec and_rect_Type5 h_conj = + h_conj __ __ + +(** val and_rect_Type3 : (__ -> __ -> 'a1) -> 'a1 **) +let rec and_rect_Type3 h_conj = + h_conj __ __ + +(** val and_rect_Type2 : (__ -> __ -> 'a1) -> 'a1 **) +let rec and_rect_Type2 h_conj = + h_conj __ __ + +(** val and_rect_Type1 : (__ -> __ -> 'a1) -> 'a1 **) +let rec and_rect_Type1 h_conj = + h_conj __ __ + +(** val and_rect_Type0 : (__ -> __ -> 'a1) -> 'a1 **) +let rec and_rect_Type0 h_conj = + h_conj __ __ + +(** val and_inv_rect_Type4 : (__ -> __ -> __ -> 'a1) -> 'a1 **) +let and_inv_rect_Type4 h1 = + let hcut = and_rect_Type4 h1 in hcut __ + +(** val and_inv_rect_Type3 : (__ -> __ -> __ -> 'a1) -> 'a1 **) +let and_inv_rect_Type3 h1 = + let hcut = and_rect_Type3 h1 in hcut __ + +(** val and_inv_rect_Type2 : (__ -> __ -> __ -> 'a1) -> 'a1 **) +let and_inv_rect_Type2 h1 = + let hcut = and_rect_Type2 h1 in hcut __ + +(** val and_inv_rect_Type1 : (__ -> __ -> __ -> 'a1) -> 'a1 **) +let and_inv_rect_Type1 h1 = + let hcut = and_rect_Type1 h1 in hcut __ + +(** val and_inv_rect_Type0 : (__ -> __ -> __ -> 'a1) -> 'a1 **) +let and_inv_rect_Type0 h1 = + let hcut = and_rect_Type0 h1 in hcut __ + +(** val r0 : 'a1 -> 'a1 **) +let r0 t = + t + +(** val r1 : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let r1 x h_refl x_19 = + eq_rect_Type0 x h_refl x_19 + +(** val r2 : 'a1 -> 'a2 -> 'a3 -> 'a1 -> 'a2 -> 'a3 **) +let r2 a0 a1 a2 b0 b1 = + eq_rect_Type0 (r1 a0 a1 b0) (r1 a0 a2 b0) b1 + +(** val r3 : 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a1 -> 'a2 -> 'a3 -> 'a4 **) +let r3 a0 a1 a2 a3 b0 b1 b2 = + eq_rect_Type0 (r2 a0 a1 a2 b0 b1) (r2 a0 a1 a3 b0 b1) b2 + +(** val r4 : + 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 **) +let r4 a0 a1 a2 a3 a4 b0 b1 b2 b3 = + eq_rect_Type0 (r3 a0 a1 a2 a3 b0 b1 b2) (r3 a0 a1 a2 a4 b0 b1 b2) b3 + +(** val streicherK : 'a1 -> 'a2 -> 'a2 **) +let streicherK t h = + eq_rect_Type3_r __ h __ + diff --git a/extracted/logic.mli b/extracted/logic.mli new file mode 100644 index 0000000..9f6be1a --- /dev/null +++ b/extracted/logic.mli @@ -0,0 +1,128 @@ +open Preamble + +open Core_notation + +open Pts + +open Hints_declaration + +val eq_rect_Type4 : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type5 : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type3 : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type2 : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type1 : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type0 : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_r : 'a1 -> 'a1 -> 'a2 -> 'a2 + +val eq_rect_Type0_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type1_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type2_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_rect_Type3_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val rewrite_l : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val rewrite_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val eq_coerc : 'a1 -> 'a2 + +val true_rect_Type4 : 'a1 -> 'a1 + +val true_rect_Type5 : 'a1 -> 'a1 + +val true_rect_Type3 : 'a1 -> 'a1 + +val true_rect_Type2 : 'a1 -> 'a1 + +val true_rect_Type1 : 'a1 -> 'a1 + +val true_rect_Type0 : 'a1 -> 'a1 + +val true_inv_rect_Type4 : (__ -> 'a1) -> 'a1 + +val true_inv_rect_Type3 : (__ -> 'a1) -> 'a1 + +val true_inv_rect_Type2 : (__ -> 'a1) -> 'a1 + +val true_inv_rect_Type1 : (__ -> 'a1) -> 'a1 + +val true_inv_rect_Type0 : (__ -> 'a1) -> 'a1 + +val true_discr : __ -> __ + +val false_rect_Type4 : __ -> 'a1 + +val false_rect_Type5 : __ -> 'a1 + +val false_rect_Type3 : __ -> 'a1 + +val false_rect_Type2 : __ -> 'a1 + +val false_rect_Type1 : __ -> 'a1 + +val false_rect_Type0 : __ -> 'a1 + +val not_rect_Type4 : (__ -> 'a1) -> 'a1 + +val not_rect_Type5 : (__ -> 'a1) -> 'a1 + +val not_rect_Type3 : (__ -> 'a1) -> 'a1 + +val not_rect_Type2 : (__ -> 'a1) -> 'a1 + +val not_rect_Type1 : (__ -> 'a1) -> 'a1 + +val not_rect_Type0 : (__ -> 'a1) -> 'a1 + +val not_inv_rect_Type4 : (__ -> __ -> 'a1) -> 'a1 + +val not_inv_rect_Type3 : (__ -> __ -> 'a1) -> 'a1 + +val not_inv_rect_Type2 : (__ -> __ -> 'a1) -> 'a1 + +val not_inv_rect_Type1 : (__ -> __ -> 'a1) -> 'a1 + +val not_inv_rect_Type0 : (__ -> __ -> 'a1) -> 'a1 + +val and_rect_Type4 : (__ -> __ -> 'a1) -> 'a1 + +val and_rect_Type5 : (__ -> __ -> 'a1) -> 'a1 + +val and_rect_Type3 : (__ -> __ -> 'a1) -> 'a1 + +val and_rect_Type2 : (__ -> __ -> 'a1) -> 'a1 + +val and_rect_Type1 : (__ -> __ -> 'a1) -> 'a1 + +val and_rect_Type0 : (__ -> __ -> 'a1) -> 'a1 + +val and_inv_rect_Type4 : (__ -> __ -> __ -> 'a1) -> 'a1 + +val and_inv_rect_Type3 : (__ -> __ -> __ -> 'a1) -> 'a1 + +val and_inv_rect_Type2 : (__ -> __ -> __ -> 'a1) -> 'a1 + +val and_inv_rect_Type1 : (__ -> __ -> __ -> 'a1) -> 'a1 + +val and_inv_rect_Type0 : (__ -> __ -> __ -> 'a1) -> 'a1 + +val r0 : 'a1 -> 'a1 + +val r1 : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val r2 : 'a1 -> 'a2 -> 'a3 -> 'a1 -> 'a2 -> 'a3 + +val r3 : 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a1 -> 'a2 -> 'a3 -> 'a4 + +val r4 : 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 + +val streicherK : 'a1 -> 'a2 -> 'a2 + diff --git a/extracted/measurable.ml b/extracted/measurable.ml new file mode 100644 index 0000000..a92ab86 --- /dev/null +++ b/extracted/measurable.ml @@ -0,0 +1,554 @@ +open Preamble + +open IO + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open SmallstepExec + +open Executions + +open Hide + +open Sets + +open Listb + +open StructuredTraces + +open Stacksize + +type classified_system = { cs_exec : (IO.io_out, IO.io_in) + SmallstepExec.fullexec; cs_global : + __; cs_labelled : (__ -> Bool.bool); + cs_classify : (__ -> + StructuredTraces.status_class); + cs_callee : (__ -> __ -> AST.ident) } + +(** val classified_system_rect_Type4 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) + -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> + 'a1) -> classified_system -> 'a1 **) +let rec classified_system_rect_Type4 h_mk_classified_system x_23662 = + let { cs_exec = cs_exec0; cs_global = cs_global0; cs_labelled = + cs_labelled0; cs_classify = cs_classify0; cs_callee = cs_callee0 } = + x_23662 + in + h_mk_classified_system cs_exec0 cs_global0 cs_labelled0 cs_classify0 + cs_callee0 + +(** val classified_system_rect_Type5 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) + -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> + 'a1) -> classified_system -> 'a1 **) +let rec classified_system_rect_Type5 h_mk_classified_system x_23664 = + let { cs_exec = cs_exec0; cs_global = cs_global0; cs_labelled = + cs_labelled0; cs_classify = cs_classify0; cs_callee = cs_callee0 } = + x_23664 + in + h_mk_classified_system cs_exec0 cs_global0 cs_labelled0 cs_classify0 + cs_callee0 + +(** val classified_system_rect_Type3 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) + -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> + 'a1) -> classified_system -> 'a1 **) +let rec classified_system_rect_Type3 h_mk_classified_system x_23666 = + let { cs_exec = cs_exec0; cs_global = cs_global0; cs_labelled = + cs_labelled0; cs_classify = cs_classify0; cs_callee = cs_callee0 } = + x_23666 + in + h_mk_classified_system cs_exec0 cs_global0 cs_labelled0 cs_classify0 + cs_callee0 + +(** val classified_system_rect_Type2 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) + -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> + 'a1) -> classified_system -> 'a1 **) +let rec classified_system_rect_Type2 h_mk_classified_system x_23668 = + let { cs_exec = cs_exec0; cs_global = cs_global0; cs_labelled = + cs_labelled0; cs_classify = cs_classify0; cs_callee = cs_callee0 } = + x_23668 + in + h_mk_classified_system cs_exec0 cs_global0 cs_labelled0 cs_classify0 + cs_callee0 + +(** val classified_system_rect_Type1 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) + -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> + 'a1) -> classified_system -> 'a1 **) +let rec classified_system_rect_Type1 h_mk_classified_system x_23670 = + let { cs_exec = cs_exec0; cs_global = cs_global0; cs_labelled = + cs_labelled0; cs_classify = cs_classify0; cs_callee = cs_callee0 } = + x_23670 + in + h_mk_classified_system cs_exec0 cs_global0 cs_labelled0 cs_classify0 + cs_callee0 + +(** val classified_system_rect_Type0 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) + -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> + 'a1) -> classified_system -> 'a1 **) +let rec classified_system_rect_Type0 h_mk_classified_system x_23672 = + let { cs_exec = cs_exec0; cs_global = cs_global0; cs_labelled = + cs_labelled0; cs_classify = cs_classify0; cs_callee = cs_callee0 } = + x_23672 + in + h_mk_classified_system cs_exec0 cs_global0 cs_labelled0 cs_classify0 + cs_callee0 + +(** val cs_exec : + classified_system -> (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let rec cs_exec xxx = + xxx.cs_exec + +(** val cs_global : classified_system -> __ **) +let rec cs_global xxx = + xxx.cs_global + +(** val cs_labelled : classified_system -> __ -> Bool.bool **) +let rec cs_labelled xxx = + xxx.cs_labelled + +(** val cs_classify : + classified_system -> __ -> StructuredTraces.status_class **) +let rec cs_classify xxx = + xxx.cs_classify + +(** val cs_callee0 : classified_system -> __ -> AST.ident **) +let rec cs_callee0 xxx s = + (xxx.cs_callee) s __ + +(** val classified_system_inv_rect_Type4 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ + -> (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> + __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let classified_system_inv_rect_Type4 hterm h1 = + let hcut = classified_system_rect_Type4 h1 hterm in hcut __ + +(** val classified_system_inv_rect_Type3 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ + -> (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> + __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let classified_system_inv_rect_Type3 hterm h1 = + let hcut = classified_system_rect_Type3 h1 hterm in hcut __ + +(** val classified_system_inv_rect_Type2 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ + -> (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> + __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let classified_system_inv_rect_Type2 hterm h1 = + let hcut = classified_system_rect_Type2 h1 hterm in hcut __ + +(** val classified_system_inv_rect_Type1 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ + -> (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> + __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let classified_system_inv_rect_Type1 hterm h1 = + let hcut = classified_system_rect_Type1 h1 hterm in hcut __ + +(** val classified_system_inv_rect_Type0 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ + -> (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> + __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let classified_system_inv_rect_Type0 hterm h1 = + let hcut = classified_system_rect_Type0 h1 hterm in hcut __ + +(** val cs_exec__o__es1 : + classified_system -> (IO.io_out, IO.io_in) SmallstepExec.trans_system **) +let cs_exec__o__es1 x0 = + x0.cs_exec.SmallstepExec.es1 + +type cs_state = __ + +(** val intensional_event_of_event : + Events.event -> StructuredTraces.intensional_event List.list **) +let intensional_event_of_event = function +| Events.EVcost l -> List.Cons ((StructuredTraces.IEVcost l), List.Nil) +| Events.EVextcall (x, x0, x1) -> List.Nil + +(** val intensional_events_of_events : + Events.trace -> StructuredTraces.intensional_event List.list **) +let intensional_events_of_events tr = + List.flatten (List.map intensional_event_of_event tr) + +(** val intensional_state_change : + classified_system -> AST.ident List.list -> __ -> (AST.ident List.list, + StructuredTraces.intensional_event List.list) Types.prod **) +let intensional_state_change c callstack s = + (match c.cs_classify s with + | StructuredTraces.Cl_return -> + (fun x -> + match callstack with + | List.Nil -> { Types.fst = List.Nil; Types.snd = List.Nil } + | List.Cons (id, tl) -> + { Types.fst = tl; Types.snd = (List.Cons ((StructuredTraces.IEVret + id), List.Nil)) }) + | StructuredTraces.Cl_jump -> + (fun x -> { Types.fst = callstack; Types.snd = List.Nil }) + | StructuredTraces.Cl_call -> + (fun callee -> + let id = callee __ in + { Types.fst = (List.Cons (id, callstack)); Types.snd = (List.Cons + ((StructuredTraces.IEVcall id), List.Nil)) }) + | StructuredTraces.Cl_tailcall -> + (fun x -> { Types.fst = callstack; Types.snd = List.Nil }) + | StructuredTraces.Cl_other -> + (fun x -> { Types.fst = callstack; Types.snd = List.Nil })) (fun _ -> + cs_callee0 c s) + +(** val intensional_trace_of_trace : + classified_system -> AST.ident List.list -> (cs_state, Events.trace) + Types.prod List.list -> (AST.ident List.list, + StructuredTraces.intensional_event List.list) Types.prod **) +let rec intensional_trace_of_trace c callstack = function +| List.Nil -> { Types.fst = callstack; Types.snd = List.Nil } +| List.Cons (str, tl) -> + let { Types.fst = s; Types.snd = tr } = str in + let { Types.fst = callstack0; Types.snd = call_event } = + intensional_state_change c callstack s + in + let other_events = intensional_events_of_events tr in + let { Types.fst = callstack1; Types.snd = rem } = + intensional_trace_of_trace c callstack0 tl + in + { Types.fst = callstack1; Types.snd = + (List.append call_event (List.append other_events rem)) } + +(** val normal_state : classified_system -> cs_state -> Bool.bool **) +let normal_state c s = + match c.cs_classify s with + | StructuredTraces.Cl_return -> Bool.False + | StructuredTraces.Cl_jump -> Bool.True + | StructuredTraces.Cl_call -> Bool.False + | StructuredTraces.Cl_tailcall -> Bool.False + | StructuredTraces.Cl_other -> Bool.True + +(** val measure_stack : + (AST.ident -> Nat.nat Types.option) -> Stacksize.stacksize_info -> + StructuredTraces.intensional_event List.list -> Stacksize.stacksize_info **) +let measure_stack costs start ev = + Stacksize.update_stacksize_info costs start + (Stacksize.extract_call_ud_from_observables ev) + +(** val will_return_aux : + classified_system -> Nat.nat -> (cs_state, Events.trace) Types.prod + List.list -> Bool.bool **) +let rec will_return_aux c depth = function +| List.Nil -> Bool.False +| List.Cons (h, tl) -> + let { Types.fst = s; Types.snd = tr } = h in + (match c.cs_classify s with + | StructuredTraces.Cl_return -> + (match depth with + | Nat.O -> + (match tl with + | List.Nil -> Bool.True + | List.Cons (x, x0) -> Bool.False) + | Nat.S d -> will_return_aux c d tl) + | StructuredTraces.Cl_jump -> will_return_aux c depth tl + | StructuredTraces.Cl_call -> will_return_aux c (Nat.S depth) tl + | StructuredTraces.Cl_tailcall -> will_return_aux c depth tl + | StructuredTraces.Cl_other -> will_return_aux c depth tl) + +(** val will_return' : + classified_system -> (cs_state, Events.trace) Types.prod List.list -> + Bool.bool **) +let will_return' c = + will_return_aux c Nat.O + +type preclassified_system = { pcs_exec : (IO.io_out, IO.io_in) + SmallstepExec.fullexec; + pcs_labelled : (__ -> __ -> Bool.bool); + pcs_classify : (__ -> __ -> + StructuredTraces.status_class); + pcs_callee : (__ -> __ -> __ -> AST.ident) } + +(** val preclassified_system_rect_Type4 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) + -> (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 **) +let rec preclassified_system_rect_Type4 h_mk_preclassified_system x_23692 = + let { pcs_exec = pcs_exec0; pcs_labelled = pcs_labelled0; pcs_classify = + pcs_classify0; pcs_callee = pcs_callee0 } = x_23692 + in + h_mk_preclassified_system pcs_exec0 pcs_labelled0 pcs_classify0 pcs_callee0 + +(** val preclassified_system_rect_Type5 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) + -> (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 **) +let rec preclassified_system_rect_Type5 h_mk_preclassified_system x_23694 = + let { pcs_exec = pcs_exec0; pcs_labelled = pcs_labelled0; pcs_classify = + pcs_classify0; pcs_callee = pcs_callee0 } = x_23694 + in + h_mk_preclassified_system pcs_exec0 pcs_labelled0 pcs_classify0 pcs_callee0 + +(** val preclassified_system_rect_Type3 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) + -> (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 **) +let rec preclassified_system_rect_Type3 h_mk_preclassified_system x_23696 = + let { pcs_exec = pcs_exec0; pcs_labelled = pcs_labelled0; pcs_classify = + pcs_classify0; pcs_callee = pcs_callee0 } = x_23696 + in + h_mk_preclassified_system pcs_exec0 pcs_labelled0 pcs_classify0 pcs_callee0 + +(** val preclassified_system_rect_Type2 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) + -> (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 **) +let rec preclassified_system_rect_Type2 h_mk_preclassified_system x_23698 = + let { pcs_exec = pcs_exec0; pcs_labelled = pcs_labelled0; pcs_classify = + pcs_classify0; pcs_callee = pcs_callee0 } = x_23698 + in + h_mk_preclassified_system pcs_exec0 pcs_labelled0 pcs_classify0 pcs_callee0 + +(** val preclassified_system_rect_Type1 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) + -> (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 **) +let rec preclassified_system_rect_Type1 h_mk_preclassified_system x_23700 = + let { pcs_exec = pcs_exec0; pcs_labelled = pcs_labelled0; pcs_classify = + pcs_classify0; pcs_callee = pcs_callee0 } = x_23700 + in + h_mk_preclassified_system pcs_exec0 pcs_labelled0 pcs_classify0 pcs_callee0 + +(** val preclassified_system_rect_Type0 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) + -> (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 **) +let rec preclassified_system_rect_Type0 h_mk_preclassified_system x_23702 = + let { pcs_exec = pcs_exec0; pcs_labelled = pcs_labelled0; pcs_classify = + pcs_classify0; pcs_callee = pcs_callee0 } = x_23702 + in + h_mk_preclassified_system pcs_exec0 pcs_labelled0 pcs_classify0 pcs_callee0 + +(** val pcs_exec : + preclassified_system -> (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let rec pcs_exec xxx = + xxx.pcs_exec + +(** val pcs_labelled : preclassified_system -> __ -> __ -> Bool.bool **) +let rec pcs_labelled xxx = + xxx.pcs_labelled + +(** val pcs_classify : + preclassified_system -> __ -> __ -> StructuredTraces.status_class **) +let rec pcs_classify xxx = + xxx.pcs_classify + +(** val pcs_callee0 : preclassified_system -> __ -> __ -> AST.ident **) +let rec pcs_callee0 xxx g s = + (xxx.pcs_callee) g s __ + +(** val preclassified_system_inv_rect_Type4 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let preclassified_system_inv_rect_Type4 hterm h1 = + let hcut = preclassified_system_rect_Type4 h1 hterm in hcut __ + +(** val preclassified_system_inv_rect_Type3 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let preclassified_system_inv_rect_Type3 hterm h1 = + let hcut = preclassified_system_rect_Type3 h1 hterm in hcut __ + +(** val preclassified_system_inv_rect_Type2 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let preclassified_system_inv_rect_Type2 hterm h1 = + let hcut = preclassified_system_rect_Type2 h1 hterm in hcut __ + +(** val preclassified_system_inv_rect_Type1 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let preclassified_system_inv_rect_Type1 hterm h1 = + let hcut = preclassified_system_rect_Type1 h1 hterm in hcut __ + +(** val preclassified_system_inv_rect_Type0 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let preclassified_system_inv_rect_Type0 hterm h1 = + let hcut = preclassified_system_rect_Type0 h1 hterm in hcut __ + +(** val pcs_exec__o__es1 : + preclassified_system -> (IO.io_out, IO.io_in) SmallstepExec.trans_system **) +let pcs_exec__o__es1 x0 = + x0.pcs_exec.SmallstepExec.es1 + +(** val pcs_to_cs : preclassified_system -> __ -> classified_system **) +let pcs_to_cs c g = + { cs_exec = c.pcs_exec; cs_global = g; cs_labelled = (c.pcs_labelled g); + cs_classify = (c.pcs_classify g); cs_callee = (fun x _ -> + pcs_callee0 c g x) } + +(** val observables : + preclassified_system -> __ -> Nat.nat -> Nat.nat -> + (StructuredTraces.intensional_event List.list, + StructuredTraces.intensional_event List.list) Types.prod Errors.res **) +let observables c p m n = + let g = c.pcs_exec.SmallstepExec.make_global p in + let c' = pcs_to_cs c g in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (c.pcs_exec.SmallstepExec.make_initial_state p)) (fun s0 -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (SmallstepExec.exec_steps m c'.cs_exec g s0)) + (fun prefix s1 -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (SmallstepExec.exec_steps n c'.cs_exec g s1)) + (fun interesting s2 -> + let { Types.fst = cs; Types.snd = prefix' } = + intensional_trace_of_trace c' List.Nil prefix + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = prefix'; + Types.snd = + (intensional_trace_of_trace c' cs interesting).Types.snd })))) + +(** val observe_all_in_measurable : + Nat.nat -> classified_system -> (StructuredTraces.intensional_event -> + Types.unit0) -> AST.ident List.list -> __ -> + (StructuredTraces.intensional_event List.list, Integers.int Errors.res) + Types.prod **) +let rec observe_all_in_measurable n fx observe callstack s = + match n with + | Nat.O -> + let res = + match (cs_exec__o__es1 fx).SmallstepExec.is_final fx.cs_global s with + | Types.None -> Errors.Error (Errors.msg ErrorMessages.NotTerminated) + | Types.Some r -> Errors.OK r + in + { Types.fst = List.Nil; Types.snd = res } + | Nat.S m -> + (match (cs_exec__o__es1 fx).SmallstepExec.is_final fx.cs_global s with + | Types.None -> + (match (cs_exec__o__es1 fx).SmallstepExec.step fx.cs_global s with + | IOMonad.Interact (x, x0) -> + { Types.fst = List.Nil; Types.snd = (Errors.Error + (Errors.msg ErrorMessages.UnexpectedIO)) } + | IOMonad.Value trs -> + let costevents = + List.flatten (List.map intensional_event_of_event trs.Types.fst) + in + let { Types.fst = callstack0; Types.snd = callevent } = + (match fx.cs_classify s with + | StructuredTraces.Cl_return -> + (fun x -> + match callstack with + | List.Nil -> { Types.fst = List.Nil; Types.snd = List.Nil } + | List.Cons (id, tl) -> + { Types.fst = tl; Types.snd = (List.Cons + ((StructuredTraces.IEVret id), List.Nil)) }) + | StructuredTraces.Cl_jump -> + (fun x -> { Types.fst = callstack; Types.snd = List.Nil }) + | StructuredTraces.Cl_call -> + (fun callee -> + let id = callee __ in + { Types.fst = (List.Cons (id, callstack)); Types.snd = + (List.Cons ((StructuredTraces.IEVcall id), List.Nil)) }) + | StructuredTraces.Cl_tailcall -> + (fun x -> { Types.fst = callstack; Types.snd = List.Nil }) + | StructuredTraces.Cl_other -> + (fun x -> { Types.fst = callstack; Types.snd = List.Nil })) + (fun _ -> cs_callee0 fx s) + in + let events = List.append costevents callevent in + let dummy = List.map observe events in + let { Types.fst = tl; Types.snd = res } = + observe_all_in_measurable m fx observe callstack0 trs.Types.snd + in + { Types.fst = (List.append events tl); Types.snd = res } + | IOMonad.Wrong m0 -> + { Types.fst = List.Nil; Types.snd = (Errors.Error m0) }) + | Types.Some r -> { Types.fst = List.Nil; Types.snd = (Errors.OK r) }) + diff --git a/extracted/measurable.mli b/extracted/measurable.mli new file mode 100644 index 0000000..434e4b4 --- /dev/null +++ b/extracted/measurable.mli @@ -0,0 +1,299 @@ +open Preamble + +open IO + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open SmallstepExec + +open Executions + +open Hide + +open Sets + +open Listb + +open StructuredTraces + +open Stacksize + +type classified_system = { cs_exec : (IO.io_out, IO.io_in) + SmallstepExec.fullexec; cs_global : + __; cs_labelled : (__ -> Bool.bool); + cs_classify : (__ -> + StructuredTraces.status_class); + cs_callee : (__ -> __ -> AST.ident) } + +val classified_system_rect_Type4 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) -> + (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> 'a1) -> + classified_system -> 'a1 + +val classified_system_rect_Type5 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) -> + (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> 'a1) -> + classified_system -> 'a1 + +val classified_system_rect_Type3 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) -> + (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> 'a1) -> + classified_system -> 'a1 + +val classified_system_rect_Type2 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) -> + (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> 'a1) -> + classified_system -> 'a1 + +val classified_system_rect_Type1 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) -> + (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> 'a1) -> + classified_system -> 'a1 + +val classified_system_rect_Type0 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> (__ -> Bool.bool) -> + (__ -> StructuredTraces.status_class) -> (__ -> __ -> AST.ident) -> 'a1) -> + classified_system -> 'a1 + +val cs_exec : + classified_system -> (IO.io_out, IO.io_in) SmallstepExec.fullexec + +val cs_global : classified_system -> __ + +val cs_labelled : classified_system -> __ -> Bool.bool + +val cs_classify : classified_system -> __ -> StructuredTraces.status_class + +val cs_callee0 : classified_system -> __ -> AST.ident + +val classified_system_inv_rect_Type4 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> + (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> + AST.ident) -> __ -> 'a1) -> 'a1 + +val classified_system_inv_rect_Type3 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> + (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> + AST.ident) -> __ -> 'a1) -> 'a1 + +val classified_system_inv_rect_Type2 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> + (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> + AST.ident) -> __ -> 'a1) -> 'a1 + +val classified_system_inv_rect_Type1 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> + (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> + AST.ident) -> __ -> 'a1) -> 'a1 + +val classified_system_inv_rect_Type0 : + classified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> __ -> + (__ -> Bool.bool) -> (__ -> StructuredTraces.status_class) -> (__ -> __ -> + AST.ident) -> __ -> 'a1) -> 'a1 + +val cs_exec__o__es1 : + classified_system -> (IO.io_out, IO.io_in) SmallstepExec.trans_system + +type cs_state = __ + +val intensional_event_of_event : + Events.event -> StructuredTraces.intensional_event List.list + +val intensional_events_of_events : + Events.trace -> StructuredTraces.intensional_event List.list + +val intensional_state_change : + classified_system -> AST.ident List.list -> __ -> (AST.ident List.list, + StructuredTraces.intensional_event List.list) Types.prod + +val intensional_trace_of_trace : + classified_system -> AST.ident List.list -> (cs_state, Events.trace) + Types.prod List.list -> (AST.ident List.list, + StructuredTraces.intensional_event List.list) Types.prod + +val normal_state : classified_system -> cs_state -> Bool.bool + +val measure_stack : + (AST.ident -> Nat.nat Types.option) -> Stacksize.stacksize_info -> + StructuredTraces.intensional_event List.list -> Stacksize.stacksize_info + +val will_return_aux : + classified_system -> Nat.nat -> (cs_state, Events.trace) Types.prod + List.list -> Bool.bool + +val will_return' : + classified_system -> (cs_state, Events.trace) Types.prod List.list -> + Bool.bool + +type preclassified_system = { pcs_exec : (IO.io_out, IO.io_in) + SmallstepExec.fullexec; + pcs_labelled : (__ -> __ -> Bool.bool); + pcs_classify : (__ -> __ -> + StructuredTraces.status_class); + pcs_callee : (__ -> __ -> __ -> AST.ident) } + +val preclassified_system_rect_Type4 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) -> + (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 + +val preclassified_system_rect_Type5 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) -> + (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 + +val preclassified_system_rect_Type3 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) -> + (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 + +val preclassified_system_rect_Type2 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) -> + (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 + +val preclassified_system_rect_Type1 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) -> + (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 + +val preclassified_system_rect_Type0 : + ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> (__ -> __ -> Bool.bool) -> + (__ -> __ -> StructuredTraces.status_class) -> (__ -> __ -> __ -> + AST.ident) -> 'a1) -> preclassified_system -> 'a1 + +val pcs_exec : + preclassified_system -> (IO.io_out, IO.io_in) SmallstepExec.fullexec + +val pcs_labelled : preclassified_system -> __ -> __ -> Bool.bool + +val pcs_classify : + preclassified_system -> __ -> __ -> StructuredTraces.status_class + +val pcs_callee0 : preclassified_system -> __ -> __ -> AST.ident + +val preclassified_system_inv_rect_Type4 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 + +val preclassified_system_inv_rect_Type3 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 + +val preclassified_system_inv_rect_Type2 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 + +val preclassified_system_inv_rect_Type1 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 + +val preclassified_system_inv_rect_Type0 : + preclassified_system -> ((IO.io_out, IO.io_in) SmallstepExec.fullexec -> + (__ -> __ -> Bool.bool) -> (__ -> __ -> StructuredTraces.status_class) -> + (__ -> __ -> __ -> AST.ident) -> __ -> 'a1) -> 'a1 + +val pcs_exec__o__es1 : + preclassified_system -> (IO.io_out, IO.io_in) SmallstepExec.trans_system + +val pcs_to_cs : preclassified_system -> __ -> classified_system + +val observables : + preclassified_system -> __ -> Nat.nat -> Nat.nat -> + (StructuredTraces.intensional_event List.list, + StructuredTraces.intensional_event List.list) Types.prod Errors.res + +val observe_all_in_measurable : + Nat.nat -> classified_system -> (StructuredTraces.intensional_event -> + Types.unit0) -> AST.ident List.list -> __ -> + (StructuredTraces.intensional_event List.list, Integers.int Errors.res) + Types.prod + diff --git a/extracted/memProperties.ml b/extracted/memProperties.ml new file mode 100644 index 0000000..fd82386 --- /dev/null +++ b/extracted/memProperties.ml @@ -0,0 +1,138 @@ +open Preamble + +open Sets + +open Listb + +open IO + +open IOMonad + +open Star + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open Frontend_misc + +open SmallstepExec + +open Cexec + +(** val z_of_offset : Pointers.offset -> Z.z **) +let z_of_offset ofs = + BitVectorZ.z_of_unsigned_bitvector Pointers.offset_size (Pointers.offv ofs) + +(** val shiftn : Pointers.offset -> Nat.nat -> Pointers.offset **) +let rec shiftn off = function +| Nat.O -> off +| Nat.S n -> + shiftn + (Pointers.shift_offset (Nat.S (Nat.S Nat.O)) off + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S Nat.O)) (Nat.S Nat.O))) n + diff --git a/extracted/memProperties.mli b/extracted/memProperties.mli new file mode 100644 index 0000000..7765652 --- /dev/null +++ b/extracted/memProperties.mli @@ -0,0 +1,130 @@ +open Preamble + +open Sets + +open Listb + +open IO + +open IOMonad + +open Star + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open Frontend_misc + +open SmallstepExec + +open Cexec + +val z_of_offset : Pointers.offset -> Z.z + +val shiftn : Pointers.offset -> Nat.nat -> Pointers.offset + diff --git a/extracted/memoryInjections.ml b/extracted/memoryInjections.ml new file mode 100644 index 0000000..86c7990 --- /dev/null +++ b/extracted/memoryInjections.ml @@ -0,0 +1,242 @@ +open Preamble + +open SmallstepExec + +open Cexec + +open Sets + +open Listb + +open IO + +open IOMonad + +open Star + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open Frontend_misc + +open MemProperties + +(** val zoo : Pointers.offset -> Z.z **) +let zoo x = + BitVectorZ.z_of_unsigned_bitvector Pointers.offset_size (Pointers.offv x) + +(** val boo : Z.z -> Pointers.offset **) +let boo x = + BitVectorZ.bitvector_of_Z Pointers.offset_size x + +(** val block_decidable_eq : + Pointers.block -> Pointers.block -> (__, __) Types.sum **) +let block_decidable_eq clearme = + let a = clearme in + (fun clearme0 -> + let b = clearme0 in + (match Z.decidable_eq_Z_Type a b with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __)) + +type embedding = + Pointers.block -> (Pointers.block, Pointers.offset) Types.prod Types.option + +(** val offset_plus : + Pointers.offset -> Pointers.offset -> Pointers.offset **) +let offset_plus o1 o2 = + Arithmetic.addition_n Pointers.offset_size (Pointers.offv o1) + (Pointers.offv o2) + +(** val pointer_translation : + Pointers.pointer -> embedding -> Pointers.pointer Types.option **) +let pointer_translation p e = + let { Pointers.pblock = pblock; Pointers.poff = poff } = p in + (match e pblock with + | Types.None -> Types.None + | Types.Some loc -> + let { Types.fst = dest_block; Types.snd = dest_off } = loc in + let ptr = { Pointers.pblock = dest_block; Pointers.poff = + (offset_plus poff dest_off) } + in + Types.Some ptr) + +(** val memory_inj_rect_Type4 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let rec memory_inj_rect_Type4 e m1 m2 h_mk_memory_inj = + h_mk_memory_inj __ __ __ __ __ __ __ + +(** val memory_inj_rect_Type5 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let rec memory_inj_rect_Type5 e m1 m2 h_mk_memory_inj = + h_mk_memory_inj __ __ __ __ __ __ __ + +(** val memory_inj_rect_Type3 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let rec memory_inj_rect_Type3 e m1 m2 h_mk_memory_inj = + h_mk_memory_inj __ __ __ __ __ __ __ + +(** val memory_inj_rect_Type2 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let rec memory_inj_rect_Type2 e m1 m2 h_mk_memory_inj = + h_mk_memory_inj __ __ __ __ __ __ __ + +(** val memory_inj_rect_Type1 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let rec memory_inj_rect_Type1 e m1 m2 h_mk_memory_inj = + h_mk_memory_inj __ __ __ __ __ __ __ + +(** val memory_inj_rect_Type0 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let rec memory_inj_rect_Type0 e m1 m2 h_mk_memory_inj = + h_mk_memory_inj __ __ __ __ __ __ __ + +(** val memory_inj_inv_rect_Type4 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let memory_inj_inv_rect_Type4 x1 x2 x3 h1 = + let hcut = memory_inj_rect_Type4 x1 x2 x3 h1 in hcut __ + +(** val memory_inj_inv_rect_Type3 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let memory_inj_inv_rect_Type3 x1 x2 x3 h1 = + let hcut = memory_inj_rect_Type3 x1 x2 x3 h1 in hcut __ + +(** val memory_inj_inv_rect_Type2 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let memory_inj_inv_rect_Type2 x1 x2 x3 h1 = + let hcut = memory_inj_rect_Type2 x1 x2 x3 h1 in hcut __ + +(** val memory_inj_inv_rect_Type1 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let memory_inj_inv_rect_Type1 x1 x2 x3 h1 = + let hcut = memory_inj_rect_Type1 x1 x2 x3 h1 in hcut __ + +(** val memory_inj_inv_rect_Type0 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let memory_inj_inv_rect_Type0 x1 x2 x3 h1 = + let hcut = memory_inj_rect_Type0 x1 x2 x3 h1 in hcut __ + +(** val memory_inj_jmdiscr : embedding -> GenMem.mem -> GenMem.mem -> __ **) +let memory_inj_jmdiscr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) __ + +(** val typesize' : Csyntax.type0 -> Nat.nat **) +let typesize' ty = + AST.typesize (Csyntax.typ_of_type ty) + diff --git a/extracted/memoryInjections.mli b/extracted/memoryInjections.mli new file mode 100644 index 0000000..e2ac1a8 --- /dev/null +++ b/extracted/memoryInjections.mli @@ -0,0 +1,191 @@ +open Preamble + +open SmallstepExec + +open Cexec + +open Sets + +open Listb + +open IO + +open IOMonad + +open Star + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open Frontend_misc + +open MemProperties + +val zoo : Pointers.offset -> Z.z + +val boo : Z.z -> Pointers.offset + +val block_decidable_eq : + Pointers.block -> Pointers.block -> (__, __) Types.sum + +type embedding = + Pointers.block -> (Pointers.block, Pointers.offset) Types.prod Types.option + +val offset_plus : Pointers.offset -> Pointers.offset -> Pointers.offset + +val pointer_translation : + Pointers.pointer -> embedding -> Pointers.pointer Types.option + +val memory_inj_rect_Type4 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val memory_inj_rect_Type5 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val memory_inj_rect_Type3 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val memory_inj_rect_Type2 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val memory_inj_rect_Type1 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val memory_inj_rect_Type0 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val memory_inj_inv_rect_Type4 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val memory_inj_inv_rect_Type3 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val memory_inj_inv_rect_Type2 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val memory_inj_inv_rect_Type1 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val memory_inj_inv_rect_Type0 : + embedding -> GenMem.mem -> GenMem.mem -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val memory_inj_jmdiscr : embedding -> GenMem.mem -> GenMem.mem -> __ + +val typesize' : Csyntax.type0 -> Nat.nat + diff --git a/extracted/monad.ml b/extracted/monad.ml new file mode 100644 index 0000000..da73da9 --- /dev/null +++ b/extracted/monad.ml @@ -0,0 +1,549 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Relations + +open Setoids + +type ('a, 'b) pred_transformer = __ + +type ('a, 'b, 'c, 'd) rel_transformer = __ + +type monad = { m_return : (__ -> __ -> __); + m_bind : (__ -> __ -> __ -> (__ -> __) -> __) } + +(** val monad_rect_Type4 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) + -> monad -> 'a1 **) +let rec monad_rect_Type4 h_mk_Monad x_744 = + let { m_return = m_return0; m_bind = m_bind0 } = x_744 in + h_mk_Monad __ m_return0 m_bind0 + +(** val monad_rect_Type5 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) + -> monad -> 'a1 **) +let rec monad_rect_Type5 h_mk_Monad x_746 = + let { m_return = m_return0; m_bind = m_bind0 } = x_746 in + h_mk_Monad __ m_return0 m_bind0 + +(** val monad_rect_Type3 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) + -> monad -> 'a1 **) +let rec monad_rect_Type3 h_mk_Monad x_748 = + let { m_return = m_return0; m_bind = m_bind0 } = x_748 in + h_mk_Monad __ m_return0 m_bind0 + +(** val monad_rect_Type2 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) + -> monad -> 'a1 **) +let rec monad_rect_Type2 h_mk_Monad x_750 = + let { m_return = m_return0; m_bind = m_bind0 } = x_750 in + h_mk_Monad __ m_return0 m_bind0 + +(** val monad_rect_Type1 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) + -> monad -> 'a1 **) +let rec monad_rect_Type1 h_mk_Monad x_752 = + let { m_return = m_return0; m_bind = m_bind0 } = x_752 in + h_mk_Monad __ m_return0 m_bind0 + +(** val monad_rect_Type0 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) + -> monad -> 'a1 **) +let rec monad_rect_Type0 h_mk_Monad x_754 = + let { m_return = m_return0; m_bind = m_bind0 } = x_754 in + h_mk_Monad __ m_return0 m_bind0 + +type 'x monad0 = __ + +(** val m_return0 : monad -> 'a1 -> __ **) +let rec m_return0 xxx x_771 = + (let { m_return = yyy; m_bind = x0 } = xxx in Obj.magic yyy) __ x_771 + +(** val m_bind0 : monad -> __ -> ('a1 -> __) -> __ **) +let rec m_bind0 xxx x_768 x_769 = + (let { m_return = x0; m_bind = yyy } = xxx in Obj.magic yyy) __ __ x_768 + x_769 + +(** val monad_inv_rect_Type4 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) + -> __ -> 'a1) -> 'a1 **) +let monad_inv_rect_Type4 hterm h1 = + let hcut = monad_rect_Type4 h1 hterm in hcut __ + +(** val monad_inv_rect_Type3 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) + -> __ -> 'a1) -> 'a1 **) +let monad_inv_rect_Type3 hterm h1 = + let hcut = monad_rect_Type3 h1 hterm in hcut __ + +(** val monad_inv_rect_Type2 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) + -> __ -> 'a1) -> 'a1 **) +let monad_inv_rect_Type2 hterm h1 = + let hcut = monad_rect_Type2 h1 hterm in hcut __ + +(** val monad_inv_rect_Type1 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) + -> __ -> 'a1) -> 'a1 **) +let monad_inv_rect_Type1 hterm h1 = + let hcut = monad_rect_Type1 h1 hterm in hcut __ + +(** val monad_inv_rect_Type0 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) + -> __ -> 'a1) -> 'a1 **) +let monad_inv_rect_Type0 hterm h1 = + let hcut = monad_rect_Type0 h1 hterm in hcut __ + +type monadProps = + monad + (* singleton inductive, whose constructor was mk_MonadProps *) + +(** val monadProps_rect_Type4 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 **) +let rec monadProps_rect_Type4 h_mk_MonadProps x_775 = + let max_def = x_775 in h_mk_MonadProps max_def __ __ __ __ + +(** val monadProps_rect_Type5 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 **) +let rec monadProps_rect_Type5 h_mk_MonadProps x_777 = + let max_def = x_777 in h_mk_MonadProps max_def __ __ __ __ + +(** val monadProps_rect_Type3 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 **) +let rec monadProps_rect_Type3 h_mk_MonadProps x_779 = + let max_def = x_779 in h_mk_MonadProps max_def __ __ __ __ + +(** val monadProps_rect_Type2 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 **) +let rec monadProps_rect_Type2 h_mk_MonadProps x_781 = + let max_def = x_781 in h_mk_MonadProps max_def __ __ __ __ + +(** val monadProps_rect_Type1 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 **) +let rec monadProps_rect_Type1 h_mk_MonadProps x_783 = + let max_def = x_783 in h_mk_MonadProps max_def __ __ __ __ + +(** val monadProps_rect_Type0 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 **) +let rec monadProps_rect_Type0 h_mk_MonadProps x_785 = + let max_def = x_785 in h_mk_MonadProps max_def __ __ __ __ + +(** val max_def : monadProps -> monad **) +let rec max_def xxx = + let yyy = xxx in yyy + +(** val monadProps_inv_rect_Type4 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadProps_inv_rect_Type4 hterm h1 = + let hcut = monadProps_rect_Type4 h1 hterm in hcut __ + +(** val monadProps_inv_rect_Type3 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadProps_inv_rect_Type3 hterm h1 = + let hcut = monadProps_rect_Type3 h1 hterm in hcut __ + +(** val monadProps_inv_rect_Type2 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadProps_inv_rect_Type2 hterm h1 = + let hcut = monadProps_rect_Type2 h1 hterm in hcut __ + +(** val monadProps_inv_rect_Type1 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadProps_inv_rect_Type1 hterm h1 = + let hcut = monadProps_rect_Type1 h1 hterm in hcut __ + +(** val monadProps_inv_rect_Type0 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadProps_inv_rect_Type0 hterm h1 = + let hcut = monadProps_rect_Type0 h1 hterm in hcut __ + +type 'x_772 max_def__o__monad = __ + +type setoidMonadProps = + monad + (* singleton inductive, whose constructor was mk_SetoidMonadProps *) + +(** val setoidMonadProps_rect_Type4 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 **) +let rec setoidMonadProps_rect_Type4 h_mk_SetoidMonadProps x_807 = + let smax_def = x_807 in + h_mk_SetoidMonadProps smax_def __ __ __ __ __ __ __ __ __ + +(** val setoidMonadProps_rect_Type5 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 **) +let rec setoidMonadProps_rect_Type5 h_mk_SetoidMonadProps x_809 = + let smax_def = x_809 in + h_mk_SetoidMonadProps smax_def __ __ __ __ __ __ __ __ __ + +(** val setoidMonadProps_rect_Type3 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 **) +let rec setoidMonadProps_rect_Type3 h_mk_SetoidMonadProps x_811 = + let smax_def = x_811 in + h_mk_SetoidMonadProps smax_def __ __ __ __ __ __ __ __ __ + +(** val setoidMonadProps_rect_Type2 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 **) +let rec setoidMonadProps_rect_Type2 h_mk_SetoidMonadProps x_813 = + let smax_def = x_813 in + h_mk_SetoidMonadProps smax_def __ __ __ __ __ __ __ __ __ + +(** val setoidMonadProps_rect_Type1 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 **) +let rec setoidMonadProps_rect_Type1 h_mk_SetoidMonadProps x_815 = + let smax_def = x_815 in + h_mk_SetoidMonadProps smax_def __ __ __ __ __ __ __ __ __ + +(** val setoidMonadProps_rect_Type0 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 **) +let rec setoidMonadProps_rect_Type0 h_mk_SetoidMonadProps x_817 = + let smax_def = x_817 in + h_mk_SetoidMonadProps smax_def __ __ __ __ __ __ __ __ __ + +(** val smax_def : setoidMonadProps -> monad **) +let rec smax_def xxx = + let yyy = xxx in yyy + +(** val setoidMonadProps_inv_rect_Type4 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoidMonadProps_inv_rect_Type4 hterm h1 = + let hcut = setoidMonadProps_rect_Type4 h1 hterm in hcut __ + +(** val setoidMonadProps_inv_rect_Type3 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoidMonadProps_inv_rect_Type3 hterm h1 = + let hcut = setoidMonadProps_rect_Type3 h1 hterm in hcut __ + +(** val setoidMonadProps_inv_rect_Type2 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoidMonadProps_inv_rect_Type2 hterm h1 = + let hcut = setoidMonadProps_rect_Type2 h1 hterm in hcut __ + +(** val setoidMonadProps_inv_rect_Type1 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoidMonadProps_inv_rect_Type1 hterm h1 = + let hcut = setoidMonadProps_rect_Type1 h1 hterm in hcut __ + +(** val setoidMonadProps_inv_rect_Type0 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoidMonadProps_inv_rect_Type0 hterm h1 = + let hcut = setoidMonadProps_rect_Type0 h1 hterm in hcut __ + +type 'x_772 smax_def__o__monad = __ + +(** val setoid_of_monad : setoidMonadProps -> Setoids.setoid **) +let setoid_of_monad m = + Setoids.Mk_Setoid + +open Bool + +open Nat + +open List + +(** val m_map : monad -> ('a1 -> 'a2) -> __ -> __ **) +let m_map m f m0 = + m_bind0 m m0 (fun x -> m_return0 m (f x)) + +(** val m_map2 : monad -> ('a1 -> 'a2 -> 'a3) -> __ -> __ -> __ **) +let m_map2 m f m0 n = + m_bind0 m m0 (fun x -> m_bind0 m n (fun y -> m_return0 m (f x y))) + +(** val m_bind2 : monad -> __ -> ('a1 -> 'a2 -> __) -> __ **) +let m_bind2 m m0 f = + m_bind0 m m0 (fun p -> f p.Types.fst p.Types.snd) + +(** val m_bind3 : monad -> __ -> ('a1 -> 'a2 -> 'a3 -> __) -> __ **) +let m_bind3 m m0 f = + m_bind0 m m0 (fun p -> + f p.Types.fst.Types.fst p.Types.fst.Types.snd p.Types.snd) + +(** val m_join : monad -> __ -> __ **) +let m_join m m0 = + m_bind0 m m0 (fun x -> x) + +(** val m_sigbind2 : monad -> __ -> ('a1 -> 'a2 -> __ -> __) -> __ **) +let m_sigbind2 m e f = + m_bind0 m e (fun e_sig -> + let p = e_sig in + (let { Types.fst = a; Types.snd = b } = p in (fun _ -> f a b __)) __) + +(** val m_list_map : monad -> ('a1 -> __) -> 'a1 List.list -> __ **) +let m_list_map m f l = + List.foldr (fun el macc -> + m_bind0 m (f el) (fun r -> + m_bind0 m macc (fun acc -> m_return0 m (List.Cons (r, acc))))) + (m_return0 m List.Nil) l + +(** val m_list_map_sigma : monad -> ('a1 -> __) -> 'a1 List.list -> __ **) +let m_list_map_sigma m f l = + List.foldr (fun el macc -> + m_bind0 m (f el) (fun eta285 -> + let r = eta285 in + m_bind0 m macc (fun eta284 -> + let acc = eta284 in m_return0 m (List.Cons (r, acc))))) + (m_return0 m List.Nil) l + +(** val m_bin_op : monad -> ('a1 -> 'a2 -> 'a3) -> __ -> __ -> __ **) +let m_bin_op m op m0 n = + m_bind0 m m0 (fun x -> m_bind0 m n (fun y -> m_return0 m (op x y))) + +(** val m_fold : + monad -> ('a1 -> 'a2 -> __) -> 'a1 List.list -> 'a2 -> __ **) +let rec m_fold m f l init = + match l with + | List.Nil -> m_return0 m init + | List.Cons (hd, tl) -> m_bind0 m (f hd init) (fun y -> m_fold m f tl y) + +(** val makeMonadProps : + (__ -> __ -> 'a1) -> (__ -> __ -> 'a1 -> (__ -> 'a1) -> 'a1) -> + monadProps **) +let makeMonadProps m_return1 m_bind1 = + { m_return = (Obj.magic m_return1); m_bind = (Obj.magic m_bind1) } + +(** val makeSetoidMonadProps : + (__ -> __ -> 'a1) -> (__ -> __ -> 'a1 -> (__ -> 'a1) -> 'a1) -> + setoidMonadProps **) +let makeSetoidMonadProps m_return1 m_bind1 = + { m_return = (Obj.magic m_return1); m_bind = (Obj.magic m_bind1) } + +open Jmeq + +open Russell + +type monadPred = +| Mk_MonadPred + +(** val monadPred_rect_Type4 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 **) +let rec monadPred_rect_Type4 m h_mk_MonadPred = function +| Mk_MonadPred -> h_mk_MonadPred __ __ __ __ + +(** val monadPred_rect_Type5 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 **) +let rec monadPred_rect_Type5 m h_mk_MonadPred = function +| Mk_MonadPred -> h_mk_MonadPred __ __ __ __ + +(** val monadPred_rect_Type3 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 **) +let rec monadPred_rect_Type3 m h_mk_MonadPred = function +| Mk_MonadPred -> h_mk_MonadPred __ __ __ __ + +(** val monadPred_rect_Type2 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 **) +let rec monadPred_rect_Type2 m h_mk_MonadPred = function +| Mk_MonadPred -> h_mk_MonadPred __ __ __ __ + +(** val monadPred_rect_Type1 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 **) +let rec monadPred_rect_Type1 m h_mk_MonadPred = function +| Mk_MonadPred -> h_mk_MonadPred __ __ __ __ + +(** val monadPred_rect_Type0 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 **) +let rec monadPred_rect_Type0 m h_mk_MonadPred = function +| Mk_MonadPred -> h_mk_MonadPred __ __ __ __ + +(** val monadPred_inv_rect_Type4 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadPred_inv_rect_Type4 x1 hterm h1 = + let hcut = monadPred_rect_Type4 x1 h1 hterm in hcut __ + +(** val monadPred_inv_rect_Type3 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadPred_inv_rect_Type3 x1 hterm h1 = + let hcut = monadPred_rect_Type3 x1 h1 hterm in hcut __ + +(** val monadPred_inv_rect_Type2 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadPred_inv_rect_Type2 x1 hterm h1 = + let hcut = monadPred_rect_Type2 x1 h1 hterm in hcut __ + +(** val monadPred_inv_rect_Type1 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadPred_inv_rect_Type1 x1 hterm h1 = + let hcut = monadPred_rect_Type1 x1 h1 hterm in hcut __ + +(** val monadPred_inv_rect_Type0 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadPred_inv_rect_Type0 x1 hterm h1 = + let hcut = monadPred_rect_Type0 x1 h1 hterm in hcut __ + +(** val monadPred_jmdiscr : monad -> monadPred -> monadPred -> __ **) +let monadPred_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let Mk_MonadPred = x in Obj.magic (fun _ dH -> dH __ __ __ __)) y + +type injMonadPred = { im_pred : monadPred; + mp_inject : (__ -> __ -> __ Types.sig0 -> __) } + +(** val injMonadPred_rect_Type4 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 **) +let rec injMonadPred_rect_Type4 m h_mk_InjMonadPred x_1048 = + let { im_pred = im_pred0; mp_inject = mp_inject0 } = x_1048 in + h_mk_InjMonadPred im_pred0 mp_inject0 __ + +(** val injMonadPred_rect_Type5 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 **) +let rec injMonadPred_rect_Type5 m h_mk_InjMonadPred x_1050 = + let { im_pred = im_pred0; mp_inject = mp_inject0 } = x_1050 in + h_mk_InjMonadPred im_pred0 mp_inject0 __ + +(** val injMonadPred_rect_Type3 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 **) +let rec injMonadPred_rect_Type3 m h_mk_InjMonadPred x_1052 = + let { im_pred = im_pred0; mp_inject = mp_inject0 } = x_1052 in + h_mk_InjMonadPred im_pred0 mp_inject0 __ + +(** val injMonadPred_rect_Type2 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 **) +let rec injMonadPred_rect_Type2 m h_mk_InjMonadPred x_1054 = + let { im_pred = im_pred0; mp_inject = mp_inject0 } = x_1054 in + h_mk_InjMonadPred im_pred0 mp_inject0 __ + +(** val injMonadPred_rect_Type1 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 **) +let rec injMonadPred_rect_Type1 m h_mk_InjMonadPred x_1056 = + let { im_pred = im_pred0; mp_inject = mp_inject0 } = x_1056 in + h_mk_InjMonadPred im_pred0 mp_inject0 __ + +(** val injMonadPred_rect_Type0 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 **) +let rec injMonadPred_rect_Type0 m h_mk_InjMonadPred x_1058 = + let { im_pred = im_pred0; mp_inject = mp_inject0 } = x_1058 in + h_mk_InjMonadPred im_pred0 mp_inject0 __ + +(** val im_pred : monad -> injMonadPred -> monadPred **) +let rec im_pred m xxx = + xxx.im_pred + +(** val mp_inject0 : monad -> injMonadPred -> __ Types.sig0 -> __ **) +let rec mp_inject0 m xxx x_1073 = + (xxx.mp_inject) __ __ x_1073 + +(** val injMonadPred_inv_rect_Type4 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) + -> __ -> __ -> 'a1) -> 'a1 **) +let injMonadPred_inv_rect_Type4 x1 hterm h1 = + let hcut = injMonadPred_rect_Type4 x1 h1 hterm in hcut __ + +(** val injMonadPred_inv_rect_Type3 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) + -> __ -> __ -> 'a1) -> 'a1 **) +let injMonadPred_inv_rect_Type3 x1 hterm h1 = + let hcut = injMonadPred_rect_Type3 x1 h1 hterm in hcut __ + +(** val injMonadPred_inv_rect_Type2 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) + -> __ -> __ -> 'a1) -> 'a1 **) +let injMonadPred_inv_rect_Type2 x1 hterm h1 = + let hcut = injMonadPred_rect_Type2 x1 h1 hterm in hcut __ + +(** val injMonadPred_inv_rect_Type1 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) + -> __ -> __ -> 'a1) -> 'a1 **) +let injMonadPred_inv_rect_Type1 x1 hterm h1 = + let hcut = injMonadPred_rect_Type1 x1 h1 hterm in hcut __ + +(** val injMonadPred_inv_rect_Type0 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) + -> __ -> __ -> 'a1) -> 'a1 **) +let injMonadPred_inv_rect_Type0 x1 hterm h1 = + let hcut = injMonadPred_rect_Type0 x1 h1 hterm in hcut __ + +(** val injMonadPred_jmdiscr : + monad -> injMonadPred -> injMonadPred -> __ **) +let injMonadPred_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { im_pred = a0; mp_inject = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +type monadRel = +| Mk_MonadRel + +(** val monadRel_rect_Type4 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 **) +let rec monadRel_rect_Type4 m1 m2 h_mk_MonadRel = function +| Mk_MonadRel -> h_mk_MonadRel __ __ __ __ + +(** val monadRel_rect_Type5 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 **) +let rec monadRel_rect_Type5 m1 m2 h_mk_MonadRel = function +| Mk_MonadRel -> h_mk_MonadRel __ __ __ __ + +(** val monadRel_rect_Type3 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 **) +let rec monadRel_rect_Type3 m1 m2 h_mk_MonadRel = function +| Mk_MonadRel -> h_mk_MonadRel __ __ __ __ + +(** val monadRel_rect_Type2 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 **) +let rec monadRel_rect_Type2 m1 m2 h_mk_MonadRel = function +| Mk_MonadRel -> h_mk_MonadRel __ __ __ __ + +(** val monadRel_rect_Type1 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 **) +let rec monadRel_rect_Type1 m1 m2 h_mk_MonadRel = function +| Mk_MonadRel -> h_mk_MonadRel __ __ __ __ + +(** val monadRel_rect_Type0 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 **) +let rec monadRel_rect_Type0 m1 m2 h_mk_MonadRel = function +| Mk_MonadRel -> h_mk_MonadRel __ __ __ __ + +(** val monadRel_inv_rect_Type4 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadRel_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = monadRel_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val monadRel_inv_rect_Type3 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadRel_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = monadRel_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val monadRel_inv_rect_Type2 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadRel_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = monadRel_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val monadRel_inv_rect_Type1 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadRel_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = monadRel_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val monadRel_inv_rect_Type0 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let monadRel_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = monadRel_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val monadRel_jmdiscr : monad -> monad -> monadRel -> monadRel -> __ **) +let monadRel_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (let Mk_MonadRel = x in Obj.magic (fun _ dH -> dH __ __ __ __)) y + diff --git a/extracted/monad.mli b/extracted/monad.mli new file mode 100644 index 0000000..968338e --- /dev/null +++ b/extracted/monad.mli @@ -0,0 +1,334 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Relations + +open Setoids + +type ('a, 'b) pred_transformer = __ + +type ('a, 'b, 'c, 'd) rel_transformer = __ + +type monad = { m_return : (__ -> __ -> __); + m_bind : (__ -> __ -> __ -> (__ -> __) -> __) } + +val monad_rect_Type4 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) -> + monad -> 'a1 + +val monad_rect_Type5 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) -> + monad -> 'a1 + +val monad_rect_Type3 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) -> + monad -> 'a1 + +val monad_rect_Type2 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) -> + monad -> 'a1 + +val monad_rect_Type1 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) -> + monad -> 'a1 + +val monad_rect_Type0 : + (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> 'a1) -> + monad -> 'a1 + +type 'x_772 monad0 + +val m_return0 : monad -> 'a1 -> __ + +val m_bind0 : monad -> __ -> ('a1 -> __) -> __ + +val monad_inv_rect_Type4 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> + __ -> 'a1) -> 'a1 + +val monad_inv_rect_Type3 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> + __ -> 'a1) -> 'a1 + +val monad_inv_rect_Type2 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> + __ -> 'a1) -> 'a1 + +val monad_inv_rect_Type1 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> + __ -> 'a1) -> 'a1 + +val monad_inv_rect_Type0 : + monad -> (__ -> (__ -> __ -> __) -> (__ -> __ -> __ -> (__ -> __) -> __) -> + __ -> 'a1) -> 'a1 + +type monadProps = + monad + (* singleton inductive, whose constructor was mk_MonadProps *) + +val monadProps_rect_Type4 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 + +val monadProps_rect_Type5 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 + +val monadProps_rect_Type3 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 + +val monadProps_rect_Type2 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 + +val monadProps_rect_Type1 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 + +val monadProps_rect_Type0 : + (monad -> __ -> __ -> __ -> __ -> 'a1) -> monadProps -> 'a1 + +val max_def : monadProps -> monad + +val monadProps_inv_rect_Type4 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadProps_inv_rect_Type3 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadProps_inv_rect_Type2 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadProps_inv_rect_Type1 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadProps_inv_rect_Type0 : + monadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +type 'x_772 max_def__o__monad = __ + +type setoidMonadProps = + monad + (* singleton inductive, whose constructor was mk_SetoidMonadProps *) + +val setoidMonadProps_rect_Type4 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 + +val setoidMonadProps_rect_Type5 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 + +val setoidMonadProps_rect_Type3 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 + +val setoidMonadProps_rect_Type2 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 + +val setoidMonadProps_rect_Type1 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 + +val setoidMonadProps_rect_Type0 : + (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + setoidMonadProps -> 'a1 + +val smax_def : setoidMonadProps -> monad + +val setoidMonadProps_inv_rect_Type4 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val setoidMonadProps_inv_rect_Type3 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val setoidMonadProps_inv_rect_Type2 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val setoidMonadProps_inv_rect_Type1 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +val setoidMonadProps_inv_rect_Type0 : + setoidMonadProps -> (monad -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 + +type 'x_772 smax_def__o__monad = __ + +val setoid_of_monad : setoidMonadProps -> Setoids.setoid + +open Bool + +open Nat + +open List + +val m_map : monad -> ('a1 -> 'a2) -> __ -> __ + +val m_map2 : monad -> ('a1 -> 'a2 -> 'a3) -> __ -> __ -> __ + +val m_bind2 : monad -> __ -> ('a1 -> 'a2 -> __) -> __ + +val m_bind3 : monad -> __ -> ('a1 -> 'a2 -> 'a3 -> __) -> __ + +val m_join : monad -> __ -> __ + +val m_sigbind2 : monad -> __ -> ('a1 -> 'a2 -> __ -> __) -> __ + +val m_list_map : monad -> ('a1 -> __) -> 'a1 List.list -> __ + +val m_list_map_sigma : monad -> ('a1 -> __) -> 'a1 List.list -> __ + +val m_bin_op : monad -> ('a1 -> 'a2 -> 'a3) -> __ -> __ -> __ + +val m_fold : monad -> ('a1 -> 'a2 -> __) -> 'a1 List.list -> 'a2 -> __ + +val makeMonadProps : + (__ -> __ -> 'a1) -> (__ -> __ -> 'a1 -> (__ -> 'a1) -> 'a1) -> monadProps + +val makeSetoidMonadProps : + (__ -> __ -> 'a1) -> (__ -> __ -> 'a1 -> (__ -> 'a1) -> 'a1) -> + setoidMonadProps + +open Jmeq + +open Russell + +type monadPred = +| Mk_MonadPred + +val monadPred_rect_Type4 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 + +val monadPred_rect_Type5 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 + +val monadPred_rect_Type3 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 + +val monadPred_rect_Type2 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 + +val monadPred_rect_Type1 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 + +val monadPred_rect_Type0 : + monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadPred -> 'a1 + +val monadPred_inv_rect_Type4 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadPred_inv_rect_Type3 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadPred_inv_rect_Type2 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadPred_inv_rect_Type1 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadPred_inv_rect_Type0 : + monad -> monadPred -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadPred_jmdiscr : monad -> monadPred -> monadPred -> __ + +type injMonadPred = { im_pred : monadPred; + mp_inject : (__ -> __ -> __ Types.sig0 -> __) } + +val injMonadPred_rect_Type4 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 + +val injMonadPred_rect_Type5 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 + +val injMonadPred_rect_Type3 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 + +val injMonadPred_rect_Type2 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 + +val injMonadPred_rect_Type1 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 + +val injMonadPred_rect_Type0 : + monad -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> __ -> 'a1) -> + injMonadPred -> 'a1 + +val im_pred : monad -> injMonadPred -> monadPred + +val mp_inject0 : monad -> injMonadPred -> __ Types.sig0 -> __ + +val injMonadPred_inv_rect_Type4 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> + __ -> __ -> 'a1) -> 'a1 + +val injMonadPred_inv_rect_Type3 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> + __ -> __ -> 'a1) -> 'a1 + +val injMonadPred_inv_rect_Type2 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> + __ -> __ -> 'a1) -> 'a1 + +val injMonadPred_inv_rect_Type1 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> + __ -> __ -> 'a1) -> 'a1 + +val injMonadPred_inv_rect_Type0 : + monad -> injMonadPred -> (monadPred -> (__ -> __ -> __ Types.sig0 -> __) -> + __ -> __ -> 'a1) -> 'a1 + +val injMonadPred_jmdiscr : monad -> injMonadPred -> injMonadPred -> __ + +type monadRel = +| Mk_MonadRel + +val monadRel_rect_Type4 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 + +val monadRel_rect_Type5 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 + +val monadRel_rect_Type3 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 + +val monadRel_rect_Type2 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 + +val monadRel_rect_Type1 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 + +val monadRel_rect_Type0 : + monad -> monad -> (__ -> __ -> __ -> __ -> 'a1) -> monadRel -> 'a1 + +val monadRel_inv_rect_Type4 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadRel_inv_rect_Type3 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadRel_inv_rect_Type2 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadRel_inv_rect_Type1 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadRel_inv_rect_Type0 : + monad -> monad -> monadRel -> (__ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val monadRel_jmdiscr : monad -> monad -> monadRel -> monadRel -> __ + diff --git a/extracted/nat.ml b/extracted/nat.ml new file mode 100644 index 0000000..ca1f6df --- /dev/null +++ b/extracted/nat.ml @@ -0,0 +1,134 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +type nat = +| O +| S of nat + +(** val nat_rect_Type4 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 **) +let rec nat_rect_Type4 h_O h_S = function +| O -> h_O +| S x_565 -> h_S x_565 (nat_rect_Type4 h_O h_S x_565) + +(** val nat_rect_Type3 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 **) +let rec nat_rect_Type3 h_O h_S = function +| O -> h_O +| S x_573 -> h_S x_573 (nat_rect_Type3 h_O h_S x_573) + +(** val nat_rect_Type2 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 **) +let rec nat_rect_Type2 h_O h_S = function +| O -> h_O +| S x_577 -> h_S x_577 (nat_rect_Type2 h_O h_S x_577) + +(** val nat_rect_Type1 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 **) +let rec nat_rect_Type1 h_O h_S = function +| O -> h_O +| S x_581 -> h_S x_581 (nat_rect_Type1 h_O h_S x_581) + +(** val nat_rect_Type0 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 **) +let rec nat_rect_Type0 h_O h_S = function +| O -> h_O +| S x_585 -> h_S x_585 (nat_rect_Type0 h_O h_S x_585) + +(** val nat_inv_rect_Type4 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let nat_inv_rect_Type4 hterm h1 h2 = + let hcut = nat_rect_Type4 h1 h2 hterm in hcut __ + +(** val nat_inv_rect_Type3 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let nat_inv_rect_Type3 hterm h1 h2 = + let hcut = nat_rect_Type3 h1 h2 hterm in hcut __ + +(** val nat_inv_rect_Type2 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let nat_inv_rect_Type2 hterm h1 h2 = + let hcut = nat_rect_Type2 h1 h2 hterm in hcut __ + +(** val nat_inv_rect_Type1 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let nat_inv_rect_Type1 hterm h1 h2 = + let hcut = nat_rect_Type1 h1 h2 hterm in hcut __ + +(** val nat_inv_rect_Type0 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 **) +let nat_inv_rect_Type0 hterm h1 h2 = + let hcut = nat_rect_Type0 h1 h2 hterm in hcut __ + +(** val nat_discr : nat -> nat -> __ **) +let nat_discr x y = + Logic.eq_rect_Type2 x + (match x with + | O -> Obj.magic (fun _ dH -> dH) + | S a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val pred : nat -> nat **) +let pred = function +| O -> O +| S p -> p + +(** val plus : nat -> nat -> nat **) +let rec plus n m = + match n with + | O -> m + | S p -> S (plus p m) + +(** val times : nat -> nat -> nat **) +let rec times n m = + match n with + | O -> O + | S p -> plus m (times p m) + +(** val minus : nat -> nat -> nat **) +let rec minus n m = + match n with + | O -> O + | S p -> + (match m with + | O -> S p + | S q -> minus p q) + +open Bool + +(** val eqb : nat -> nat -> Bool.bool **) +let rec eqb n m = + match n with + | O -> + (match m with + | O -> Bool.True + | S q -> Bool.False) + | S p -> + (match m with + | O -> Bool.False + | S q -> eqb p q) + +(** val leb : nat -> nat -> Bool.bool **) +let rec leb n m = + match n with + | O -> Bool.True + | S p -> + (match m with + | O -> Bool.False + | S q -> leb p q) + +(** val min : nat -> nat -> nat **) +let min n m = + match leb n m with + | Bool.True -> n + | Bool.False -> m + +(** val max : nat -> nat -> nat **) +let max n m = + match leb n m with + | Bool.True -> m + | Bool.False -> n + diff --git a/extracted/nat.mli b/extracted/nat.mli new file mode 100644 index 0000000..30a1988 --- /dev/null +++ b/extracted/nat.mli @@ -0,0 +1,61 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +type nat = +| O +| S of nat + +val nat_rect_Type4 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 + +val nat_rect_Type3 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 + +val nat_rect_Type2 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 + +val nat_rect_Type1 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 + +val nat_rect_Type0 : 'a1 -> (nat -> 'a1 -> 'a1) -> nat -> 'a1 + +val nat_inv_rect_Type4 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val nat_inv_rect_Type3 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val nat_inv_rect_Type2 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val nat_inv_rect_Type1 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val nat_inv_rect_Type0 : + nat -> (__ -> 'a1) -> (nat -> (__ -> 'a1) -> __ -> 'a1) -> 'a1 + +val nat_discr : nat -> nat -> __ + +val pred : nat -> nat + +val plus : nat -> nat -> nat + +val times : nat -> nat -> nat + +val minus : nat -> nat -> nat + +open Bool + +val eqb : nat -> nat -> Bool.bool + +val leb : nat -> nat -> Bool.bool + +val min : nat -> nat -> nat + +val max : nat -> nat -> nat + diff --git a/extracted/option.ml b/extracted/option.ml new file mode 100644 index 0000000..ad5d3fb --- /dev/null +++ b/extracted/option.ml @@ -0,0 +1,55 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Monad + +(** val option : Monad.monadProps **) +let option = + Monad.makeMonadProps (fun _ x -> Types.Some x) (fun _ _ m f -> + match m with + | Types.None -> Types.None + | Types.Some x -> f x) + +(** val opt_safe : 'a1 Types.option -> 'a1 **) +let opt_safe m = + (match m with + | Types.None -> (fun _ -> Logic.false_rect_Type0 __) + | Types.Some t -> (fun _ -> t)) __ + +(** val opt_try_catch : 'a1 Types.option -> (Types.unit0 -> 'a1) -> 'a1 **) +let opt_try_catch m f = + match m with + | Types.None -> f Types.It + | Types.Some x -> x + +(** val optPred : Monad.injMonadPred **) +let optPred = + { Monad.im_pred = Monad.Mk_MonadPred; Monad.mp_inject = (fun _ _ m_sig -> + let m = m_sig in + (match Obj.magic m with + | Types.None -> (fun _ -> Obj.magic Types.None) + | Types.Some x -> (fun _ -> Obj.magic (Types.Some x))) __) } + diff --git a/extracted/option.mli b/extracted/option.mli new file mode 100644 index 0000000..0600ff7 --- /dev/null +++ b/extracted/option.mli @@ -0,0 +1,36 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Monad + +val option : Monad.monadProps + +val opt_safe : 'a1 Types.option -> 'a1 + +val opt_try_catch : 'a1 Types.option -> (Types.unit0 -> 'a1) -> 'a1 + +val optPred : Monad.injMonadPred + diff --git a/extracted/order.ml b/extracted/order.ml new file mode 100644 index 0000000..857c5f9 --- /dev/null +++ b/extracted/order.ml @@ -0,0 +1,86 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +type order = +| Order_lt +| Order_eq +| Order_gt + +(** val order_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 **) +let rec order_rect_Type4 h_order_lt h_order_eq h_order_gt = function +| Order_lt -> h_order_lt +| Order_eq -> h_order_eq +| Order_gt -> h_order_gt + +(** val order_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 **) +let rec order_rect_Type5 h_order_lt h_order_eq h_order_gt = function +| Order_lt -> h_order_lt +| Order_eq -> h_order_eq +| Order_gt -> h_order_gt + +(** val order_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 **) +let rec order_rect_Type3 h_order_lt h_order_eq h_order_gt = function +| Order_lt -> h_order_lt +| Order_eq -> h_order_eq +| Order_gt -> h_order_gt + +(** val order_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 **) +let rec order_rect_Type2 h_order_lt h_order_eq h_order_gt = function +| Order_lt -> h_order_lt +| Order_eq -> h_order_eq +| Order_gt -> h_order_gt + +(** val order_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 **) +let rec order_rect_Type1 h_order_lt h_order_eq h_order_gt = function +| Order_lt -> h_order_lt +| Order_eq -> h_order_eq +| Order_gt -> h_order_gt + +(** val order_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 **) +let rec order_rect_Type0 h_order_lt h_order_eq h_order_gt = function +| Order_lt -> h_order_lt +| Order_eq -> h_order_eq +| Order_gt -> h_order_gt + +(** val order_inv_rect_Type4 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let order_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = order_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val order_inv_rect_Type3 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let order_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = order_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val order_inv_rect_Type2 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let order_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = order_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val order_inv_rect_Type1 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let order_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = order_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val order_inv_rect_Type0 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let order_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = order_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val order_discr : order -> order -> __ **) +let order_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Order_lt -> Obj.magic (fun _ dH -> dH) + | Order_eq -> Obj.magic (fun _ dH -> dH) + | Order_gt -> Obj.magic (fun _ dH -> dH)) y + diff --git a/extracted/order.mli b/extracted/order.mli new file mode 100644 index 0000000..face231 --- /dev/null +++ b/extracted/order.mli @@ -0,0 +1,46 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +type order = +| Order_lt +| Order_eq +| Order_gt + +val order_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 + +val order_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 + +val order_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 + +val order_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 + +val order_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 + +val order_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> order -> 'a1 + +val order_inv_rect_Type4 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val order_inv_rect_Type3 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val order_inv_rect_Type2 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val order_inv_rect_Type1 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val order_inv_rect_Type0 : + order -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val order_discr : order -> order -> __ + diff --git a/extracted/pointers.ml b/extracted/pointers.ml new file mode 100644 index 0000000..964838e --- /dev/null +++ b/extracted/pointers.ml @@ -0,0 +1,385 @@ +open Preamble + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +type block = + Z.z + (* singleton inductive, whose constructor was mk_block *) + +(** val block_rect_Type4 : (Z.z -> 'a1) -> block -> 'a1 **) +let rec block_rect_Type4 h_mk_block x_5028 = + let block_id = x_5028 in h_mk_block block_id + +(** val block_rect_Type5 : (Z.z -> 'a1) -> block -> 'a1 **) +let rec block_rect_Type5 h_mk_block x_5030 = + let block_id = x_5030 in h_mk_block block_id + +(** val block_rect_Type3 : (Z.z -> 'a1) -> block -> 'a1 **) +let rec block_rect_Type3 h_mk_block x_5032 = + let block_id = x_5032 in h_mk_block block_id + +(** val block_rect_Type2 : (Z.z -> 'a1) -> block -> 'a1 **) +let rec block_rect_Type2 h_mk_block x_5034 = + let block_id = x_5034 in h_mk_block block_id + +(** val block_rect_Type1 : (Z.z -> 'a1) -> block -> 'a1 **) +let rec block_rect_Type1 h_mk_block x_5036 = + let block_id = x_5036 in h_mk_block block_id + +(** val block_rect_Type0 : (Z.z -> 'a1) -> block -> 'a1 **) +let rec block_rect_Type0 h_mk_block x_5038 = + let block_id = x_5038 in h_mk_block block_id + +(** val block_id : block -> Z.z **) +let rec block_id xxx = + let yyy = xxx in yyy + +(** val block_inv_rect_Type4 : block -> (Z.z -> __ -> 'a1) -> 'a1 **) +let block_inv_rect_Type4 hterm h1 = + let hcut = block_rect_Type4 h1 hterm in hcut __ + +(** val block_inv_rect_Type3 : block -> (Z.z -> __ -> 'a1) -> 'a1 **) +let block_inv_rect_Type3 hterm h1 = + let hcut = block_rect_Type3 h1 hterm in hcut __ + +(** val block_inv_rect_Type2 : block -> (Z.z -> __ -> 'a1) -> 'a1 **) +let block_inv_rect_Type2 hterm h1 = + let hcut = block_rect_Type2 h1 hterm in hcut __ + +(** val block_inv_rect_Type1 : block -> (Z.z -> __ -> 'a1) -> 'a1 **) +let block_inv_rect_Type1 hterm h1 = + let hcut = block_rect_Type1 h1 hterm in hcut __ + +(** val block_inv_rect_Type0 : block -> (Z.z -> __ -> 'a1) -> 'a1 **) +let block_inv_rect_Type0 hterm h1 = + let hcut = block_rect_Type0 h1 hterm in hcut __ + +(** val block_discr : block -> block -> __ **) +let block_discr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val block_jmdiscr : block -> block -> __ **) +let block_jmdiscr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val block_region : block -> AST.region **) +let block_region b = + match Z.zleb (block_id b) Z.OZ with + | Bool.True -> AST.Code + | Bool.False -> AST.XData + +(** val dummy_block_code : block **) +let dummy_block_code = + Z.OZ + +(** val eq_block : block -> block -> Bool.bool **) +let eq_block b1 b2 = + Z.eqZb (block_id b1) (block_id b2) + +(** val block_eq : Deqsets.deqSet **) +let block_eq = + Obj.magic eq_block + +(** val offset_size : Nat.nat **) +let offset_size = + Nat.times (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) AST.size_pointer + +type offset = + BitVector.bitVector + (* singleton inductive, whose constructor was mk_offset *) + +(** val offset_rect_Type4 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 **) +let rec offset_rect_Type4 h_mk_offset x_5054 = + let offv = x_5054 in h_mk_offset offv + +(** val offset_rect_Type5 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 **) +let rec offset_rect_Type5 h_mk_offset x_5056 = + let offv = x_5056 in h_mk_offset offv + +(** val offset_rect_Type3 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 **) +let rec offset_rect_Type3 h_mk_offset x_5058 = + let offv = x_5058 in h_mk_offset offv + +(** val offset_rect_Type2 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 **) +let rec offset_rect_Type2 h_mk_offset x_5060 = + let offv = x_5060 in h_mk_offset offv + +(** val offset_rect_Type1 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 **) +let rec offset_rect_Type1 h_mk_offset x_5062 = + let offv = x_5062 in h_mk_offset offv + +(** val offset_rect_Type0 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 **) +let rec offset_rect_Type0 h_mk_offset x_5064 = + let offv = x_5064 in h_mk_offset offv + +(** val offv : offset -> BitVector.bitVector **) +let rec offv xxx = + let yyy = xxx in yyy + +(** val offset_inv_rect_Type4 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let offset_inv_rect_Type4 hterm h1 = + let hcut = offset_rect_Type4 h1 hterm in hcut __ + +(** val offset_inv_rect_Type3 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let offset_inv_rect_Type3 hterm h1 = + let hcut = offset_rect_Type3 h1 hterm in hcut __ + +(** val offset_inv_rect_Type2 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let offset_inv_rect_Type2 hterm h1 = + let hcut = offset_rect_Type2 h1 hterm in hcut __ + +(** val offset_inv_rect_Type1 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let offset_inv_rect_Type1 hterm h1 = + let hcut = offset_rect_Type1 h1 hterm in hcut __ + +(** val offset_inv_rect_Type0 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 **) +let offset_inv_rect_Type0 hterm h1 = + let hcut = offset_rect_Type0 h1 hterm in hcut __ + +(** val offset_discr : offset -> offset -> __ **) +let offset_discr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val offset_jmdiscr : offset -> offset -> __ **) +let offset_jmdiscr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + +(** val eq_offset : offset -> offset -> Bool.bool **) +let eq_offset x y = + BitVector.eq_bv offset_size (offv x) (offv y) + +(** val offset_of_Z : Z.z -> offset **) +let offset_of_Z z = + BitVectorZ.bitvector_of_Z offset_size z + +(** val shift_offset : Nat.nat -> offset -> BitVector.bitVector -> offset **) +let shift_offset n o i = + Arithmetic.addition_n offset_size (offv o) + (Arithmetic.sign_ext n offset_size i) + +(** val shift_offset_n : + Nat.nat -> offset -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + offset **) +let shift_offset_n n o i sg j = + Arithmetic.addition_n offset_size (offv o) + (Arithmetic.short_multiplication offset_size + (Arithmetic.bitvector_of_nat offset_size i) + (match sg with + | AST.Signed -> Arithmetic.sign_ext n offset_size j + | AST.Unsigned -> Arithmetic.zero_ext n offset_size j)) + +(** val neg_shift_offset : + Nat.nat -> offset -> BitVector.bitVector -> offset **) +let neg_shift_offset n o i = + Arithmetic.subtraction offset_size (offv o) + (Arithmetic.sign_ext n offset_size i) + +(** val neg_shift_offset_n : + Nat.nat -> offset -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + offset **) +let neg_shift_offset_n n o i sg j = + Arithmetic.subtraction offset_size (offv o) + (Arithmetic.short_multiplication offset_size + (Arithmetic.bitvector_of_nat offset_size i) + (match sg with + | AST.Signed -> Arithmetic.sign_ext n offset_size j + | AST.Unsigned -> Arithmetic.zero_ext n offset_size j)) + +(** val sub_offset : Nat.nat -> offset -> offset -> BitVector.bitVector **) +let sub_offset n x y = + Arithmetic.sign_ext offset_size n + (Arithmetic.subtraction offset_size (offv x) (offv y)) + +(** val zero_offset : offset **) +let zero_offset = + BitVector.zero offset_size + +(** val lt_offset : offset -> offset -> Bool.bool **) +let lt_offset x y = + Arithmetic.lt_u offset_size (offv x) (offv y) + +type pointer = { pblock : block; poff : offset } + +(** val pointer_rect_Type4 : (block -> offset -> 'a1) -> pointer -> 'a1 **) +let rec pointer_rect_Type4 h_mk_pointer x_5080 = + let { pblock = pblock0; poff = poff0 } = x_5080 in + h_mk_pointer pblock0 poff0 + +(** val pointer_rect_Type5 : (block -> offset -> 'a1) -> pointer -> 'a1 **) +let rec pointer_rect_Type5 h_mk_pointer x_5082 = + let { pblock = pblock0; poff = poff0 } = x_5082 in + h_mk_pointer pblock0 poff0 + +(** val pointer_rect_Type3 : (block -> offset -> 'a1) -> pointer -> 'a1 **) +let rec pointer_rect_Type3 h_mk_pointer x_5084 = + let { pblock = pblock0; poff = poff0 } = x_5084 in + h_mk_pointer pblock0 poff0 + +(** val pointer_rect_Type2 : (block -> offset -> 'a1) -> pointer -> 'a1 **) +let rec pointer_rect_Type2 h_mk_pointer x_5086 = + let { pblock = pblock0; poff = poff0 } = x_5086 in + h_mk_pointer pblock0 poff0 + +(** val pointer_rect_Type1 : (block -> offset -> 'a1) -> pointer -> 'a1 **) +let rec pointer_rect_Type1 h_mk_pointer x_5088 = + let { pblock = pblock0; poff = poff0 } = x_5088 in + h_mk_pointer pblock0 poff0 + +(** val pointer_rect_Type0 : (block -> offset -> 'a1) -> pointer -> 'a1 **) +let rec pointer_rect_Type0 h_mk_pointer x_5090 = + let { pblock = pblock0; poff = poff0 } = x_5090 in + h_mk_pointer pblock0 poff0 + +(** val pblock : pointer -> block **) +let rec pblock xxx = + xxx.pblock + +(** val poff : pointer -> offset **) +let rec poff xxx = + xxx.poff + +(** val pointer_inv_rect_Type4 : + pointer -> (block -> offset -> __ -> 'a1) -> 'a1 **) +let pointer_inv_rect_Type4 hterm h1 = + let hcut = pointer_rect_Type4 h1 hterm in hcut __ + +(** val pointer_inv_rect_Type3 : + pointer -> (block -> offset -> __ -> 'a1) -> 'a1 **) +let pointer_inv_rect_Type3 hterm h1 = + let hcut = pointer_rect_Type3 h1 hterm in hcut __ + +(** val pointer_inv_rect_Type2 : + pointer -> (block -> offset -> __ -> 'a1) -> 'a1 **) +let pointer_inv_rect_Type2 hterm h1 = + let hcut = pointer_rect_Type2 h1 hterm in hcut __ + +(** val pointer_inv_rect_Type1 : + pointer -> (block -> offset -> __ -> 'a1) -> 'a1 **) +let pointer_inv_rect_Type1 hterm h1 = + let hcut = pointer_rect_Type1 h1 hterm in hcut __ + +(** val pointer_inv_rect_Type0 : + pointer -> (block -> offset -> __ -> 'a1) -> 'a1 **) +let pointer_inv_rect_Type0 hterm h1 = + let hcut = pointer_rect_Type0 h1 hterm in hcut __ + +(** val pointer_discr : pointer -> pointer -> __ **) +let pointer_discr x y = + Logic.eq_rect_Type2 x + (let { pblock = a0; poff = a1 } = x in Obj.magic (fun _ dH -> dH __ __)) + y + +(** val pointer_jmdiscr : pointer -> pointer -> __ **) +let pointer_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { pblock = a0; poff = a1 } = x in Obj.magic (fun _ dH -> dH __ __)) + y + +(** val ptype : pointer -> AST.region **) +let ptype p = + block_region p.pblock + +(** val shift_pointer : + Nat.nat -> pointer -> BitVector.bitVector -> pointer **) +let shift_pointer n p i = + { pblock = p.pblock; poff = (shift_offset n p.poff i) } + +(** val shift_pointer_n : + Nat.nat -> pointer -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + pointer **) +let shift_pointer_n n p i sg j = + { pblock = p.pblock; poff = (shift_offset_n n p.poff i sg j) } + +(** val neg_shift_pointer : + Nat.nat -> pointer -> BitVector.bitVector -> pointer **) +let neg_shift_pointer n p i = + { pblock = p.pblock; poff = (neg_shift_offset n p.poff i) } + +(** val neg_shift_pointer_n : + Nat.nat -> pointer -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + pointer **) +let neg_shift_pointer_n n p i sg j = + { pblock = p.pblock; poff = (neg_shift_offset_n n p.poff i sg j) } + +(** val eq_pointer : pointer -> pointer -> Bool.bool **) +let eq_pointer p1 p2 = + Bool.andb (eq_block p1.pblock p2.pblock) (eq_offset p1.poff p2.poff) + diff --git a/extracted/pointers.mli b/extracted/pointers.mli new file mode 100644 index 0000000..f215886 --- /dev/null +++ b/extracted/pointers.mli @@ -0,0 +1,225 @@ +open Preamble + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +type block = + Z.z + (* singleton inductive, whose constructor was mk_block *) + +val block_rect_Type4 : (Z.z -> 'a1) -> block -> 'a1 + +val block_rect_Type5 : (Z.z -> 'a1) -> block -> 'a1 + +val block_rect_Type3 : (Z.z -> 'a1) -> block -> 'a1 + +val block_rect_Type2 : (Z.z -> 'a1) -> block -> 'a1 + +val block_rect_Type1 : (Z.z -> 'a1) -> block -> 'a1 + +val block_rect_Type0 : (Z.z -> 'a1) -> block -> 'a1 + +val block_id : block -> Z.z + +val block_inv_rect_Type4 : block -> (Z.z -> __ -> 'a1) -> 'a1 + +val block_inv_rect_Type3 : block -> (Z.z -> __ -> 'a1) -> 'a1 + +val block_inv_rect_Type2 : block -> (Z.z -> __ -> 'a1) -> 'a1 + +val block_inv_rect_Type1 : block -> (Z.z -> __ -> 'a1) -> 'a1 + +val block_inv_rect_Type0 : block -> (Z.z -> __ -> 'a1) -> 'a1 + +val block_discr : block -> block -> __ + +val block_jmdiscr : block -> block -> __ + +val block_region : block -> AST.region + +val dummy_block_code : block + +val eq_block : block -> block -> Bool.bool + +val block_eq : Deqsets.deqSet + +val offset_size : Nat.nat + +type offset = + BitVector.bitVector + (* singleton inductive, whose constructor was mk_offset *) + +val offset_rect_Type4 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 + +val offset_rect_Type5 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 + +val offset_rect_Type3 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 + +val offset_rect_Type2 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 + +val offset_rect_Type1 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 + +val offset_rect_Type0 : (BitVector.bitVector -> 'a1) -> offset -> 'a1 + +val offv : offset -> BitVector.bitVector + +val offset_inv_rect_Type4 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val offset_inv_rect_Type3 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val offset_inv_rect_Type2 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val offset_inv_rect_Type1 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val offset_inv_rect_Type0 : + offset -> (BitVector.bitVector -> __ -> 'a1) -> 'a1 + +val offset_discr : offset -> offset -> __ + +val offset_jmdiscr : offset -> offset -> __ + +val eq_offset : offset -> offset -> Bool.bool + +val offset_of_Z : Z.z -> offset + +val shift_offset : Nat.nat -> offset -> BitVector.bitVector -> offset + +val shift_offset_n : + Nat.nat -> offset -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + offset + +val neg_shift_offset : Nat.nat -> offset -> BitVector.bitVector -> offset + +val neg_shift_offset_n : + Nat.nat -> offset -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + offset + +val sub_offset : Nat.nat -> offset -> offset -> BitVector.bitVector + +val zero_offset : offset + +val lt_offset : offset -> offset -> Bool.bool + +type pointer = { pblock : block; poff : offset } + +val pointer_rect_Type4 : (block -> offset -> 'a1) -> pointer -> 'a1 + +val pointer_rect_Type5 : (block -> offset -> 'a1) -> pointer -> 'a1 + +val pointer_rect_Type3 : (block -> offset -> 'a1) -> pointer -> 'a1 + +val pointer_rect_Type2 : (block -> offset -> 'a1) -> pointer -> 'a1 + +val pointer_rect_Type1 : (block -> offset -> 'a1) -> pointer -> 'a1 + +val pointer_rect_Type0 : (block -> offset -> 'a1) -> pointer -> 'a1 + +val pblock : pointer -> block + +val poff : pointer -> offset + +val pointer_inv_rect_Type4 : pointer -> (block -> offset -> __ -> 'a1) -> 'a1 + +val pointer_inv_rect_Type3 : pointer -> (block -> offset -> __ -> 'a1) -> 'a1 + +val pointer_inv_rect_Type2 : pointer -> (block -> offset -> __ -> 'a1) -> 'a1 + +val pointer_inv_rect_Type1 : pointer -> (block -> offset -> __ -> 'a1) -> 'a1 + +val pointer_inv_rect_Type0 : pointer -> (block -> offset -> __ -> 'a1) -> 'a1 + +val pointer_discr : pointer -> pointer -> __ + +val pointer_jmdiscr : pointer -> pointer -> __ + +val ptype : pointer -> AST.region + +val shift_pointer : Nat.nat -> pointer -> BitVector.bitVector -> pointer + +val shift_pointer_n : + Nat.nat -> pointer -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + pointer + +val neg_shift_pointer : Nat.nat -> pointer -> BitVector.bitVector -> pointer + +val neg_shift_pointer_n : + Nat.nat -> pointer -> Nat.nat -> AST.signedness -> BitVector.bitVector -> + pointer + +val eq_pointer : pointer -> pointer -> Bool.bool + diff --git a/extracted/policy.ml b/extracted/policy.ml new file mode 100644 index 0000000..194fc73 --- /dev/null +++ b/extracted/policy.ml @@ -0,0 +1,193 @@ +open Preamble + +open Assembly + +open Status + +open Fetch + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open ASM + +open PolicyFront + +open PolicyStep + +(** val jump_expansion_internal : + ASM.labelled_instruction List.list Types.sig0 -> Nat.nat -> (Bool.bool, + PolicyFront.ppc_pc_map Types.option) Types.prod Types.sig0 **) +let rec jump_expansion_internal program n = + let labels = PolicyFront.create_label_map (Types.pi1 program) in + let rec aux res = +prerr_endline "JEI_start"; + let { Types.fst = no_ch; Types.snd = z } = res in + match z with + | Types.None -> + { Types.fst = Bool.False; Types.snd = Types.None } + | Types.Some op -> + match no_ch with + | Bool.True -> res + | Bool.False -> + aux + (Types.pi1 + (PolicyStep.jump_expansion_step program (Types.pi1 labels) + op)) + in + aux + { Types.fst = Bool.False; Types.snd = + (Types.pi1 + (PolicyFront.jump_expansion_start program (Types.pi1 labels))) } +(* + (match n with + | Nat.O -> + (fun _ -> { Types.fst = Bool.False; Types.snd = + (Types.pi1 + (PolicyFront.jump_expansion_start program (Types.pi1 labels))) }) + | Nat.S m -> + (fun _ -> + let res = Types.pi1 (jump_expansion_internal program m) in + (let { Types.fst = no_ch; Types.snd = z } = res in + (fun _ -> + (match z with + | Types.None -> + (fun _ -> { Types.fst = Bool.False; Types.snd = Types.None }) + | Types.Some op -> + (fun _ -> + match no_ch with + | Bool.True -> res + | Bool.False -> + Types.pi1 + (PolicyStep.jump_expansion_step program (Types.pi1 labels) + op))) __)) __)) __*) + +(** val measure_int : + ASM.labelled_instruction List.list -> PolicyFront.ppc_pc_map -> Nat.nat + -> Nat.nat **) +let rec measure_int program policy acc = + match program with + | List.Nil -> acc + | List.Cons (h, t) -> + (match (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (List.length t)) + policy.Types.snd { Types.fst = Nat.O; Types.snd = + Assembly.Short_jump }).Types.snd with + | Assembly.Short_jump -> measure_int t policy acc + | Assembly.Absolute_jump -> + measure_int t policy (Nat.plus acc (Nat.S Nat.O)) + | Assembly.Long_jump -> + measure_int t policy (Nat.plus acc (Nat.S (Nat.S Nat.O)))) + +(** val je_fixpoint : + ASM.labelled_instruction List.list Types.sig0 -> PolicyFront.ppc_pc_map + Types.option Types.sig0 **) +let je_fixpoint program = + (Types.pi1 + (jump_expansion_internal program (Nat.S + (Nat.times (Nat.S (Nat.S Nat.O)) (List.length (Types.pi1 program)))))).Types.snd + +(** val jump_expansion' : + ASM.pseudo_assembly_program -> (BitVector.word -> BitVector.word, + BitVector.word -> Bool.bool) Types.prod Types.sig0 Types.option **) +let jump_expansion' program = + let program' = program.ASM.code in + let f = Types.pi1 (je_fixpoint program') in + (match f with + | Types.None -> (fun _ -> Types.None) + | Types.Some x -> + (fun _ -> Types.Some { Types.fst = (fun ppc -> + let pc = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) ppc x.Types.snd { Types.fst = Nat.O; + Types.snd = Assembly.Short_jump }).Types.fst + in + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) pc); Types.snd = (fun ppc -> + let jl = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) ppc x.Types.snd { Types.fst = Nat.O; + Types.snd = Assembly.Short_jump }).Types.snd + in + PolicyFront.jmpeqb jl Assembly.Long_jump) })) __ + diff --git a/extracted/policy.mli b/extracted/policy.mli new file mode 100644 index 0000000..3d8eb7f --- /dev/null +++ b/extracted/policy.mli @@ -0,0 +1,106 @@ +open Preamble + +open Assembly + +open Status + +open Fetch + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open ASM + +open PolicyFront + +open PolicyStep + +val jump_expansion_internal : + ASM.labelled_instruction List.list Types.sig0 -> Nat.nat -> (Bool.bool, + PolicyFront.ppc_pc_map Types.option) Types.prod Types.sig0 + +val measure_int : + ASM.labelled_instruction List.list -> PolicyFront.ppc_pc_map -> Nat.nat -> + Nat.nat + +val je_fixpoint : + ASM.labelled_instruction List.list Types.sig0 -> PolicyFront.ppc_pc_map + Types.option Types.sig0 + +val jump_expansion' : + ASM.pseudo_assembly_program -> (BitVector.word -> BitVector.word, + BitVector.word -> Bool.bool) Types.prod Types.sig0 Types.option + diff --git a/extracted/policyFront.ml b/extracted/policyFront.ml new file mode 100644 index 0000000..1b8ccc5 --- /dev/null +++ b/extracted/policyFront.ml @@ -0,0 +1,689 @@ +open Preamble + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open ASM + +open Fetch + +open Status + +open Assembly + +type ppc_pc_map = + (Nat.nat, (Nat.nat, Assembly.jump_length) Types.prod + BitVectorTrie.bitVectorTrie) Types.prod + +(** val jmpeqb : + Assembly.jump_length -> Assembly.jump_length -> Bool.bool **) +let jmpeqb j1 j2 = + match j1 with + | Assembly.Short_jump -> + (match j2 with + | Assembly.Short_jump -> Bool.True + | Assembly.Absolute_jump -> Bool.False + | Assembly.Long_jump -> Bool.False) + | Assembly.Absolute_jump -> + (match j2 with + | Assembly.Short_jump -> Bool.False + | Assembly.Absolute_jump -> Bool.True + | Assembly.Long_jump -> Bool.False) + | Assembly.Long_jump -> + (match j2 with + | Assembly.Short_jump -> Bool.False + | Assembly.Absolute_jump -> Bool.False + | Assembly.Long_jump -> Bool.True) + +(** val expand_relative_jump_internal_unsafe : + Assembly.jump_length -> (ASM.subaddressing_mode -> ASM.subaddressing_mode + ASM.preinstruction) -> ASM.instruction List.list **) +let expand_relative_jump_internal_unsafe jmp_len i = + match jmp_len with + | Assembly.Short_jump -> + List.Cons ((ASM.RealInstruction + (i (ASM.RELATIVE + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))), List.Nil) + | Assembly.Absolute_jump -> List.Nil + | Assembly.Long_jump -> + List.Cons ((ASM.RealInstruction + (i (ASM.RELATIVE + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S Nat.O)))))), + (List.Cons ((ASM.SJMP (ASM.RELATIVE + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S Nat.O)))))), + (List.Cons ((ASM.LJMP (ASM.ADDR16 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))), List.Nil))))) + +(** val strip_target : + ASM.identifier ASM.preinstruction -> (ASM.subaddressing_mode -> + ASM.subaddressing_mode ASM.preinstruction, ASM.instruction) Types.sum **) +let strip_target = function +| ASM.ADD (arg1, arg2) -> + Types.Inr (ASM.RealInstruction (ASM.ADD (arg1, arg2))) +| ASM.ADDC (arg1, arg2) -> + Types.Inr (ASM.RealInstruction (ASM.ADDC (arg1, arg2))) +| ASM.SUBB (arg1, arg2) -> + Types.Inr (ASM.RealInstruction (ASM.SUBB (arg1, arg2))) +| ASM.INC arg -> Types.Inr (ASM.RealInstruction (ASM.INC arg)) +| ASM.DEC arg -> Types.Inr (ASM.RealInstruction (ASM.DEC arg)) +| ASM.MUL (arg1, arg2) -> + Types.Inr (ASM.RealInstruction (ASM.MUL (arg1, arg2))) +| ASM.DIV (arg1, arg2) -> + Types.Inr (ASM.RealInstruction (ASM.DIV (arg1, arg2))) +| ASM.DA arg -> Types.Inr (ASM.RealInstruction (ASM.DA arg)) +| ASM.JC x -> Types.Inl (fun x0 -> ASM.JC x0) +| ASM.JNC x -> Types.Inl (fun x0 -> ASM.JNC x0) +| ASM.JB (baddr, x) -> Types.Inl (fun x0 -> ASM.JB (baddr, x0)) +| ASM.JNB (baddr, x) -> Types.Inl (fun x0 -> ASM.JNB (baddr, x0)) +| ASM.JBC (baddr, x) -> Types.Inl (fun x0 -> ASM.JBC (baddr, x0)) +| ASM.JZ x -> Types.Inl (fun x0 -> ASM.JZ x0) +| ASM.JNZ x -> Types.Inl (fun x0 -> ASM.JNZ x0) +| ASM.CJNE (addr, x) -> Types.Inl (fun x0 -> ASM.CJNE (addr, x0)) +| ASM.DJNZ (addr, x) -> Types.Inl (fun x0 -> ASM.DJNZ (addr, x0)) +| ASM.ANL arg -> Types.Inr (ASM.RealInstruction (ASM.ANL arg)) +| ASM.ORL arg -> Types.Inr (ASM.RealInstruction (ASM.ORL arg)) +| ASM.XRL arg -> Types.Inr (ASM.RealInstruction (ASM.XRL arg)) +| ASM.CLR arg -> Types.Inr (ASM.RealInstruction (ASM.CLR arg)) +| ASM.CPL arg -> Types.Inr (ASM.RealInstruction (ASM.CPL arg)) +| ASM.RL arg -> Types.Inr (ASM.RealInstruction (ASM.RL arg)) +| ASM.RLC arg -> Types.Inr (ASM.RealInstruction (ASM.RLC arg)) +| ASM.RR arg -> Types.Inr (ASM.RealInstruction (ASM.RR arg)) +| ASM.RRC arg -> Types.Inr (ASM.RealInstruction (ASM.RRC arg)) +| ASM.SWAP arg -> Types.Inr (ASM.RealInstruction (ASM.SWAP arg)) +| ASM.MOV arg -> Types.Inr (ASM.RealInstruction (ASM.MOV arg)) +| ASM.MOVX arg -> Types.Inr (ASM.RealInstruction (ASM.MOVX arg)) +| ASM.SETB arg -> Types.Inr (ASM.RealInstruction (ASM.SETB arg)) +| ASM.PUSH arg -> Types.Inr (ASM.RealInstruction (ASM.PUSH arg)) +| ASM.POP arg -> Types.Inr (ASM.RealInstruction (ASM.POP arg)) +| ASM.XCH (arg1, arg2) -> + Types.Inr (ASM.RealInstruction (ASM.XCH (arg1, arg2))) +| ASM.XCHD (arg1, arg2) -> + Types.Inr (ASM.RealInstruction (ASM.XCHD (arg1, arg2))) +| ASM.RET -> Types.Inr (ASM.RealInstruction ASM.RET) +| ASM.RETI -> Types.Inr (ASM.RealInstruction ASM.RETI) +| ASM.NOP -> Types.Inr (ASM.RealInstruction ASM.NOP) +| ASM.JMP dst -> Types.Inr (ASM.RealInstruction (ASM.JMP dst)) + +(** val expand_relative_jump_unsafe : + Assembly.jump_length -> ASM.identifier ASM.preinstruction -> + ASM.instruction List.list **) +let expand_relative_jump_unsafe jmp_len i = + match strip_target i with + | Types.Inl jmp -> expand_relative_jump_internal_unsafe jmp_len jmp + | Types.Inr instr -> List.Cons (instr, List.Nil) + +(** val expand_pseudo_instruction_unsafe : + Assembly.jump_length -> ASM.pseudo_instruction -> ASM.instruction + List.list **) +let expand_pseudo_instruction_unsafe jmp_len = function +| ASM.Instruction instr -> expand_relative_jump_unsafe jmp_len instr +| ASM.Comment comment -> List.Nil +| ASM.Cost cost -> List.Cons ((ASM.RealInstruction ASM.NOP), List.Nil) +| ASM.Jmp jmp -> + (match jmp_len with + | Assembly.Short_jump -> + List.Cons ((ASM.SJMP (ASM.RELATIVE + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))), List.Nil) + | Assembly.Absolute_jump -> + List.Cons ((ASM.AJMP (ASM.ADDR11 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))), List.Nil) + | Assembly.Long_jump -> + List.Cons ((ASM.LJMP (ASM.ADDR16 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))), List.Nil)) +| ASM.Jnz (acc, dst1, dst2) -> + List.Cons ((ASM.RealInstruction (ASM.JNZ (ASM.RELATIVE + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S Nat.O))))))), + (List.Cons ((ASM.LJMP (ASM.ADDR16 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))), (List.Cons ((ASM.LJMP (ASM.ADDR16 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))), List.Nil))))) +| ASM.Call call -> + (match jmp_len with + | Assembly.Short_jump -> List.Nil + | Assembly.Absolute_jump -> + List.Cons ((ASM.ACALL (ASM.ADDR11 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))), List.Nil) + | Assembly.Long_jump -> + List.Cons ((ASM.LCALL (ASM.ADDR16 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))), List.Nil)) +| ASM.Mov (d, trgt, off) -> + (match d with + | Types.Inl x -> + let address = ASM.DATA16 + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) + in + List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl (Types.Inl + (Types.Inr { Types.fst = ASM.DPTR; Types.snd = address }))))), List.Nil) + | Types.Inr pr -> + let v = ASM.DATA + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) + in + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), ASM.Acc_a, (Vector.VCons ((Nat.S + Nat.O), ASM.Direct, (Vector.VCons (Nat.O, ASM.Registr, + Vector.VEmpty)))))) pr.Types.fst with + | ASM.DIRECT b1 -> + (fun _ -> List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inr { Types.fst = (ASM.DIRECT b1); + Types.snd = v })))))), List.Nil)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER r -> + (fun _ -> List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inl (Types.Inr { Types.fst = + (ASM.REGISTER r); Types.snd = v }))))))), List.Nil)) + | ASM.ACC_A -> + (fun _ -> List.Cons ((ASM.RealInstruction (ASM.MOV (Types.Inl + (Types.Inl (Types.Inl (Types.Inl (Types.Inl { Types.fst = + ASM.ACC_A; Types.snd = v }))))))), List.Nil)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __) + +(** val instruction_size_jmplen : + Assembly.jump_length -> ASM.pseudo_instruction -> Nat.nat **) +let instruction_size_jmplen jmp_len i = + let mapped = + List.map Assembly.assembly1 (expand_pseudo_instruction_unsafe jmp_len i) + in + let flattened = List.flatten mapped in + let pc_len = List.length flattened in pc_len + +(** val max_length : + Assembly.jump_length -> Assembly.jump_length -> Assembly.jump_length **) +let max_length j1 j2 = + match j1 with + | Assembly.Short_jump -> + (match j2 with + | Assembly.Short_jump -> Assembly.Short_jump + | Assembly.Absolute_jump -> Assembly.Long_jump + | Assembly.Long_jump -> Assembly.Long_jump) + | Assembly.Absolute_jump -> + (match j2 with + | Assembly.Short_jump -> Assembly.Long_jump + | Assembly.Absolute_jump -> Assembly.Absolute_jump + | Assembly.Long_jump -> Assembly.Long_jump) + | Assembly.Long_jump -> Assembly.Long_jump + +(** val dec_jmple : + Assembly.jump_length -> Assembly.jump_length -> (__, __) Types.sum **) +let dec_jmple x y = + match x with + | Assembly.Short_jump -> + (match y with + | Assembly.Short_jump -> Types.Inr __ + | Assembly.Absolute_jump -> Types.Inl __ + | Assembly.Long_jump -> Types.Inl __) + | Assembly.Absolute_jump -> + (match y with + | Assembly.Short_jump -> Types.Inr __ + | Assembly.Absolute_jump -> Types.Inr __ + | Assembly.Long_jump -> Types.Inl __) + | Assembly.Long_jump -> + (match y with + | Assembly.Short_jump -> Types.Inr __ + | Assembly.Absolute_jump -> Types.Inr __ + | Assembly.Long_jump -> Types.Inr __) + +(** val dec_eq_jump_length : + Assembly.jump_length -> Assembly.jump_length -> (__, __) Types.sum **) +let dec_eq_jump_length a b = + match a with + | Assembly.Short_jump -> + (match b with + | Assembly.Short_jump -> Types.Inl __ + | Assembly.Absolute_jump -> Types.Inr __ + | Assembly.Long_jump -> Types.Inr __) + | Assembly.Absolute_jump -> + (match b with + | Assembly.Short_jump -> Types.Inr __ + | Assembly.Absolute_jump -> Types.Inl __ + | Assembly.Long_jump -> Types.Inr __) + | Assembly.Long_jump -> + (match b with + | Assembly.Short_jump -> Types.Inr __ + | Assembly.Absolute_jump -> Types.Inr __ + | Assembly.Long_jump -> Types.Inl __) + +(** val create_label_map : + ASM.labelled_instruction List.list -> Fetch.label_map Types.sig0 **) +let create_label_map program = + (Fetch.create_label_cost_map program).Types.fst + +(** val select_reljump_length : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier + -> Nat.nat -> Assembly.jump_length **) +let select_reljump_length labels old_sigma inc_sigma ppc lbl ins_len = + let paddr = Identifiers.lookup_def PreIdentifiers.ASMTag labels lbl Nat.O + in + let { Types.fst = src; Types.snd = dest } = + match Nat.leb paddr ppc with + | Bool.True -> + let pc = inc_sigma.Types.fst in + let addr = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) paddr) inc_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + { Types.fst = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.plus pc ins_len)); Types.snd = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr) } + | Bool.False -> + let pc = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) ppc) old_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + let addr = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) paddr) old_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + { Types.fst = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.plus pc ins_len)); Types.snd = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr) } + in + let { Types.fst = sj_possible; Types.snd = disp } = + Assembly.short_jump_cond src dest + in + (match sj_possible with + | Bool.True -> Assembly.Short_jump + | Bool.False -> Assembly.Long_jump) + +(** val select_call_length : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier + -> Assembly.jump_length **) +let select_call_length labels old_sigma inc_sigma ppc lbl = + let paddr = Identifiers.lookup_def PreIdentifiers.ASMTag labels lbl Nat.O + in + let { Types.fst = src; Types.snd = dest } = + match Nat.leb paddr ppc with + | Bool.True -> + let pc = inc_sigma.Types.fst in + let addr = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) paddr) inc_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + { Types.fst = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.plus pc (Nat.S (Nat.S Nat.O)))); + Types.snd = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr) } + | Bool.False -> + let pc = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) ppc) old_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + let addr = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) paddr) old_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + { Types.fst = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.plus pc (Nat.S (Nat.S Nat.O)))); + Types.snd = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr) } + in + let { Types.fst = aj_possible; Types.snd = disp } = + Assembly.absolute_jump_cond src dest + in + (match aj_possible with + | Bool.True -> Assembly.Absolute_jump + | Bool.False -> Assembly.Long_jump) + +(** val select_jump_length : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier + -> Assembly.jump_length **) +let select_jump_length labels old_sigma inc_sigma ppc lbl = + let paddr = Identifiers.lookup_def PreIdentifiers.ASMTag labels lbl Nat.O + in + let { Types.fst = src; Types.snd = dest } = + match Nat.leb paddr ppc with + | Bool.True -> + let pc = inc_sigma.Types.fst in + let addr = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) paddr) inc_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + { Types.fst = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.plus pc (Nat.S (Nat.S Nat.O)))); + Types.snd = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr) } + | Bool.False -> + let pc = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) ppc) old_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + let addr = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) paddr) old_sigma.Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.fst + in + { Types.fst = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) (Nat.plus pc (Nat.S (Nat.S Nat.O)))); + Types.snd = + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr) } + in + let { Types.fst = sj_possible; Types.snd = disp } = + Assembly.short_jump_cond src dest + in + (match sj_possible with + | Bool.True -> Assembly.Short_jump + | Bool.False -> select_call_length labels old_sigma inc_sigma ppc lbl) + +(** val destination_of : + ASM.identifier ASM.preinstruction -> ASM.identifier Types.option **) +let destination_of = function +| ASM.ADD (x, x0) -> Types.None +| ASM.ADDC (x, x0) -> Types.None +| ASM.SUBB (x, x0) -> Types.None +| ASM.INC x -> Types.None +| ASM.DEC x -> Types.None +| ASM.MUL (x, x0) -> Types.None +| ASM.DIV (x, x0) -> Types.None +| ASM.DA x -> Types.None +| ASM.JC j -> Types.Some j +| ASM.JNC j -> Types.Some j +| ASM.JB (x, j) -> Types.Some j +| ASM.JNB (x, j) -> Types.Some j +| ASM.JBC (x, j) -> Types.Some j +| ASM.JZ j -> Types.Some j +| ASM.JNZ j -> Types.Some j +| ASM.CJNE (x, j) -> Types.Some j +| ASM.DJNZ (x, j) -> Types.Some j +| ASM.ANL x -> Types.None +| ASM.ORL x -> Types.None +| ASM.XRL x -> Types.None +| ASM.CLR x -> Types.None +| ASM.CPL x -> Types.None +| ASM.RL x -> Types.None +| ASM.RLC x -> Types.None +| ASM.RR x -> Types.None +| ASM.RRC x -> Types.None +| ASM.SWAP x -> Types.None +| ASM.MOV x -> Types.None +| ASM.MOVX x -> Types.None +| ASM.SETB x -> Types.None +| ASM.PUSH x -> Types.None +| ASM.POP x -> Types.None +| ASM.XCH (x, x0) -> Types.None +| ASM.XCHD (x, x0) -> Types.None +| ASM.RET -> Types.None +| ASM.RETI -> Types.None +| ASM.NOP -> Types.None +| ASM.JMP x -> Types.None + +(** val length_of : ASM.identifier ASM.preinstruction -> Nat.nat **) +let length_of = function +| ASM.ADD (x, x0) -> Nat.O +| ASM.ADDC (x, x0) -> Nat.O +| ASM.SUBB (x, x0) -> Nat.O +| ASM.INC x -> Nat.O +| ASM.DEC x -> Nat.O +| ASM.MUL (x, x0) -> Nat.O +| ASM.DIV (x, x0) -> Nat.O +| ASM.DA x -> Nat.O +| ASM.JC j -> Nat.S (Nat.S Nat.O) +| ASM.JNC j -> Nat.S (Nat.S Nat.O) +| ASM.JB (x, j) -> Nat.S (Nat.S (Nat.S Nat.O)) +| ASM.JNB (x, j) -> Nat.S (Nat.S (Nat.S Nat.O)) +| ASM.JBC (x, j) -> Nat.S (Nat.S (Nat.S Nat.O)) +| ASM.JZ j -> Nat.S (Nat.S Nat.O) +| ASM.JNZ j -> Nat.S (Nat.S Nat.O) +| ASM.CJNE (x, j) -> Nat.S (Nat.S (Nat.S Nat.O)) +| ASM.DJNZ (x, j) -> + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + ASM.Registr, (Vector.VCons (Nat.O, ASM.Direct, Vector.VEmpty)))) x with + | ASM.DIRECT x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.INDIRECT x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.EXT_INDIRECT x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.REGISTER x0 -> Nat.S (Nat.S Nat.O) + | ASM.ACC_A -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.ACC_B -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.DPTR -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.DATA x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.DATA16 x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.ACC_DPTR -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.ACC_PC -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.EXT_INDIRECT_DPTR -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.INDIRECT_DPTR -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.CARRY -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.BIT_ADDR x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.N_BIT_ADDR x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.RELATIVE x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.ADDR11 x0 -> Nat.S (Nat.S (Nat.S Nat.O)) + | ASM.ADDR16 x0 -> Nat.S (Nat.S (Nat.S Nat.O))) +| ASM.ANL x -> Nat.O +| ASM.ORL x -> Nat.O +| ASM.XRL x -> Nat.O +| ASM.CLR x -> Nat.O +| ASM.CPL x -> Nat.O +| ASM.RL x -> Nat.O +| ASM.RLC x -> Nat.O +| ASM.RR x -> Nat.O +| ASM.RRC x -> Nat.O +| ASM.SWAP x -> Nat.O +| ASM.MOV x -> Nat.O +| ASM.MOVX x -> Nat.O +| ASM.SETB x -> Nat.O +| ASM.PUSH x -> Nat.O +| ASM.POP x -> Nat.O +| ASM.XCH (x, x0) -> Nat.O +| ASM.XCHD (x, x0) -> Nat.O +| ASM.RET -> Nat.O +| ASM.RETI -> Nat.O +| ASM.NOP -> Nat.O +| ASM.JMP x -> Nat.O + +(** val jump_expansion_step_instruction : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier + ASM.preinstruction -> Assembly.jump_length Types.option **) +let jump_expansion_step_instruction labels old_sigma inc_sigma ppc i = + let ins_len = length_of i in + (match destination_of i with + | Types.None -> Types.None + | Types.Some j -> + Types.Some + (select_reljump_length labels old_sigma inc_sigma ppc j ins_len)) + +(** val jump_expansion_start : + ASM.labelled_instruction List.list Types.sig0 -> Fetch.label_map -> + ppc_pc_map Types.option Types.sig0 **) +let jump_expansion_start program labels = + let final_policy = + FoldStuff.foldl_strong (Types.pi1 program) (fun prefix x tl _ p -> + let { Types.fst = pc; Types.snd = sigma } = Types.pi1 p in + let { Types.fst = label; Types.snd = instr } = x in + let isize = instruction_size_jmplen Assembly.Short_jump instr in + { Types.fst = (Nat.plus pc isize); Types.snd = + (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S (List.length prefix))) + { Types.fst = (Nat.plus pc isize); Types.snd = Assembly.Short_jump } + sigma) }) { Types.fst = Nat.O; Types.snd = + (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) Nat.O) { Types.fst = Nat.O; + Types.snd = Assembly.Short_jump } (BitVectorTrie.Stub (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))))) } + in + (match Util.gtb (Types.pi1 final_policy).Types.fst + (Exp.exp (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))))))))))) with + | Bool.True -> (fun _ -> Types.None) + | Bool.False -> (fun _ -> Types.Some (Types.pi1 final_policy))) __ + diff --git a/extracted/policyFront.mli b/extracted/policyFront.mli new file mode 100644 index 0000000..d2a2c58 --- /dev/null +++ b/extracted/policyFront.mli @@ -0,0 +1,147 @@ +open Preamble + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open ASM + +open Fetch + +open Status + +open Assembly + +type ppc_pc_map = + (Nat.nat, (Nat.nat, Assembly.jump_length) Types.prod + BitVectorTrie.bitVectorTrie) Types.prod + +val jmpeqb : Assembly.jump_length -> Assembly.jump_length -> Bool.bool + +val expand_relative_jump_internal_unsafe : + Assembly.jump_length -> (ASM.subaddressing_mode -> ASM.subaddressing_mode + ASM.preinstruction) -> ASM.instruction List.list + +val strip_target : + ASM.identifier ASM.preinstruction -> (ASM.subaddressing_mode -> + ASM.subaddressing_mode ASM.preinstruction, ASM.instruction) Types.sum + +val expand_relative_jump_unsafe : + Assembly.jump_length -> ASM.identifier ASM.preinstruction -> + ASM.instruction List.list + +val expand_pseudo_instruction_unsafe : + Assembly.jump_length -> ASM.pseudo_instruction -> ASM.instruction List.list + +val instruction_size_jmplen : + Assembly.jump_length -> ASM.pseudo_instruction -> Nat.nat + +val max_length : + Assembly.jump_length -> Assembly.jump_length -> Assembly.jump_length + +val dec_jmple : + Assembly.jump_length -> Assembly.jump_length -> (__, __) Types.sum + +val dec_eq_jump_length : + Assembly.jump_length -> Assembly.jump_length -> (__, __) Types.sum + +val create_label_map : + ASM.labelled_instruction List.list -> Fetch.label_map Types.sig0 + +val select_reljump_length : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier -> + Nat.nat -> Assembly.jump_length + +val select_call_length : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier -> + Assembly.jump_length + +val select_jump_length : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier -> + Assembly.jump_length + +val destination_of : + ASM.identifier ASM.preinstruction -> ASM.identifier Types.option + +val length_of : ASM.identifier ASM.preinstruction -> Nat.nat + +val jump_expansion_step_instruction : + Fetch.label_map -> ppc_pc_map -> ppc_pc_map -> Nat.nat -> ASM.identifier + ASM.preinstruction -> Assembly.jump_length Types.option + +val jump_expansion_start : + ASM.labelled_instruction List.list Types.sig0 -> Fetch.label_map -> + ppc_pc_map Types.option Types.sig0 + diff --git a/extracted/policyStep.ml b/extracted/policyStep.ml new file mode 100644 index 0000000..ddc45e9 --- /dev/null +++ b/extracted/policyStep.ml @@ -0,0 +1,211 @@ +open Preamble + +open Assembly + +open Status + +open Fetch + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open ASM + +open PolicyFront + +(** val jump_expansion_step : + ASM.labelled_instruction List.list Types.sig0 -> Fetch.label_map + Types.sig0 -> PolicyFront.ppc_pc_map Types.sig0 -> (Bool.bool, + PolicyFront.ppc_pc_map Types.option) Types.prod Types.sig0 **) +let jump_expansion_step program labels old_sigma = + (let { Types.fst = final_added; Types.snd = final_policy } = + Types.pi1 + (FoldStuff.foldl_strong (Types.pi1 program) (fun prefix x tl _ acc -> + (let { Types.fst = inc_added; Types.snd = inc_pc_sigma } = + Types.pi1 acc + in + (fun _ -> + (let { Types.fst = label; Types.snd = instr } = x in + (fun _ -> + let add_instr = + match instr with + | ASM.Instruction i -> + PolicyFront.jump_expansion_step_instruction (Types.pi1 labels) + (Types.pi1 old_sigma) inc_pc_sigma (List.length prefix) i + | ASM.Comment x0 -> Types.None + | ASM.Cost x0 -> Types.None + | ASM.Jmp j -> + Types.Some + (PolicyFront.select_jump_length (Types.pi1 labels) + (Types.pi1 old_sigma) inc_pc_sigma (List.length prefix) j) + | ASM.Jnz (x0, x1, x2) -> Types.None + | ASM.Call c -> + Types.Some + (PolicyFront.select_call_length (Types.pi1 labels) + (Types.pi1 old_sigma) inc_pc_sigma (List.length prefix) c) + | ASM.Mov (x0, x1, x2) -> Types.None + in + let { Types.fst = inc_pc; Types.snd = inc_sigma } = inc_pc_sigma in + let old_length = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (List.length prefix)) + (Types.pi1 old_sigma).Types.snd { Types.fst = Nat.O; Types.snd = + Assembly.Short_jump }).Types.snd + in + let old_size = PolicyFront.instruction_size_jmplen old_length instr + in + let { Types.fst = new_length; Types.snd = isize } = + match add_instr with + | Types.None -> + { Types.fst = Assembly.Short_jump; Types.snd = + (PolicyFront.instruction_size_jmplen Assembly.Short_jump + instr) } + | Types.Some pl -> + { Types.fst = (PolicyFront.max_length old_length pl); + Types.snd = + (PolicyFront.instruction_size_jmplen + (PolicyFront.max_length old_length pl) instr) } + in + let new_added = + match add_instr with + | Types.None -> inc_added + | Types.Some x0 -> Nat.plus inc_added (Nat.minus isize old_size) + in + let old_Slength = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S + (List.length prefix))) (Types.pi1 old_sigma).Types.snd + { Types.fst = Nat.O; Types.snd = Assembly.Short_jump }).Types.snd + in + let updated_sigma = + BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) (Nat.S + (List.length prefix))) { Types.fst = (Nat.plus inc_pc isize); + Types.snd = old_Slength } + (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) + (List.length prefix)) { Types.fst = inc_pc; Types.snd = + new_length } inc_sigma) + in + { Types.fst = new_added; Types.snd = { Types.fst = + (Nat.plus inc_pc isize); Types.snd = updated_sigma } })) __)) __) + { Types.fst = Nat.O; Types.snd = { Types.fst = Nat.O; Types.snd = + (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) Nat.O) { Types.fst = Nat.O; + Types.snd = + (BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) Nat.O) + (Types.pi1 old_sigma).Types.snd { Types.fst = Nat.O; Types.snd = + Assembly.Short_jump }).Types.snd } (BitVectorTrie.Stub (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))))) } }) + in + (fun _ -> + (match Util.gtb final_policy.Types.fst + (Exp.exp (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))))))))))) with + | Bool.True -> + (fun _ -> { Types.fst = (Nat.eqb final_added Nat.O); Types.snd = + Types.None }) + | Bool.False -> + (fun _ -> { Types.fst = (Nat.eqb final_added Nat.O); Types.snd = + (Types.Some final_policy) })) __)) __ + diff --git a/extracted/policyStep.mli b/extracted/policyStep.mli new file mode 100644 index 0000000..1e23bab --- /dev/null +++ b/extracted/policyStep.mli @@ -0,0 +1,93 @@ +open Preamble + +open Assembly + +open Status + +open Fetch + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open CostLabel + +open ASM + +open PolicyFront + +val jump_expansion_step : + ASM.labelled_instruction List.list Types.sig0 -> Fetch.label_map Types.sig0 + -> PolicyFront.ppc_pc_map Types.sig0 -> (Bool.bool, PolicyFront.ppc_pc_map + Types.option) Types.prod Types.sig0 + diff --git a/extracted/positive.ml b/extracted/positive.ml new file mode 100644 index 0000000..390c62b --- /dev/null +++ b/extracted/positive.ml @@ -0,0 +1,410 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Bool + +open Relations + +open Nat + +type compare = +| LT +| EQ +| GT + +(** val compare_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 **) +let rec compare_rect_Type4 h_LT h_EQ h_GT = function +| LT -> h_LT +| EQ -> h_EQ +| GT -> h_GT + +(** val compare_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 **) +let rec compare_rect_Type5 h_LT h_EQ h_GT = function +| LT -> h_LT +| EQ -> h_EQ +| GT -> h_GT + +(** val compare_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 **) +let rec compare_rect_Type3 h_LT h_EQ h_GT = function +| LT -> h_LT +| EQ -> h_EQ +| GT -> h_GT + +(** val compare_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 **) +let rec compare_rect_Type2 h_LT h_EQ h_GT = function +| LT -> h_LT +| EQ -> h_EQ +| GT -> h_GT + +(** val compare_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 **) +let rec compare_rect_Type1 h_LT h_EQ h_GT = function +| LT -> h_LT +| EQ -> h_EQ +| GT -> h_GT + +(** val compare_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 **) +let rec compare_rect_Type0 h_LT h_EQ h_GT = function +| LT -> h_LT +| EQ -> h_EQ +| GT -> h_GT + +(** val compare_inv_rect_Type4 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let compare_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = compare_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val compare_inv_rect_Type3 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let compare_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = compare_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val compare_inv_rect_Type2 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let compare_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = compare_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val compare_inv_rect_Type1 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let compare_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = compare_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val compare_inv_rect_Type0 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let compare_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = compare_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val compare_discr : compare -> compare -> __ **) +let compare_discr x y = + Logic.eq_rect_Type2 x + (match x with + | LT -> Obj.magic (fun _ dH -> dH) + | EQ -> Obj.magic (fun _ dH -> dH) + | GT -> Obj.magic (fun _ dH -> dH)) y + +(** val compare_invert : compare -> compare **) +let compare_invert = function +| LT -> GT +| EQ -> EQ +| GT -> LT + +type pos = +| One +| P1 of pos +| P0 of pos + +(** val pos_rect_Type4 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 **) +let rec pos_rect_Type4 h_one h_p1 h_p0 = function +| One -> h_one +| P1 x_1606 -> h_p1 x_1606 (pos_rect_Type4 h_one h_p1 h_p0 x_1606) +| P0 x_1607 -> h_p0 x_1607 (pos_rect_Type4 h_one h_p1 h_p0 x_1607) + +(** val pos_rect_Type3 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 **) +let rec pos_rect_Type3 h_one h_p1 h_p0 = function +| One -> h_one +| P1 x_1618 -> h_p1 x_1618 (pos_rect_Type3 h_one h_p1 h_p0 x_1618) +| P0 x_1619 -> h_p0 x_1619 (pos_rect_Type3 h_one h_p1 h_p0 x_1619) + +(** val pos_rect_Type2 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 **) +let rec pos_rect_Type2 h_one h_p1 h_p0 = function +| One -> h_one +| P1 x_1624 -> h_p1 x_1624 (pos_rect_Type2 h_one h_p1 h_p0 x_1624) +| P0 x_1625 -> h_p0 x_1625 (pos_rect_Type2 h_one h_p1 h_p0 x_1625) + +(** val pos_rect_Type1 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 **) +let rec pos_rect_Type1 h_one h_p1 h_p0 = function +| One -> h_one +| P1 x_1630 -> h_p1 x_1630 (pos_rect_Type1 h_one h_p1 h_p0 x_1630) +| P0 x_1631 -> h_p0 x_1631 (pos_rect_Type1 h_one h_p1 h_p0 x_1631) + +(** val pos_rect_Type0 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 **) +let rec pos_rect_Type0 h_one h_p1 h_p0 = function +| One -> h_one +| P1 x_1636 -> h_p1 x_1636 (pos_rect_Type0 h_one h_p1 h_p0 x_1636) +| P0 x_1637 -> h_p0 x_1637 (pos_rect_Type0 h_one h_p1 h_p0 x_1637) + +(** val pos_inv_rect_Type4 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 **) +let pos_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = pos_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val pos_inv_rect_Type3 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 **) +let pos_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = pos_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val pos_inv_rect_Type2 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 **) +let pos_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = pos_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val pos_inv_rect_Type1 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 **) +let pos_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = pos_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val pos_inv_rect_Type0 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 **) +let pos_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = pos_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val pos_discr : pos -> pos -> __ **) +let pos_discr x y = + Logic.eq_rect_Type2 x + (match x with + | One -> Obj.magic (fun _ dH -> dH) + | P1 a0 -> Obj.magic (fun _ dH -> dH __) + | P0 a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val pred : pos -> pos **) +let rec pred = function +| One -> One +| P1 ps -> P0 ps +| P0 ps -> + (match ps with + | One -> One + | P1 x -> P1 (pred ps) + | P0 x -> P1 (pred ps)) + +(** val succ : pos -> pos **) +let rec succ = function +| One -> P0 One +| P1 ps -> P0 (succ ps) +| P0 ps -> P1 ps + +(** val nat_of_pos : pos -> Nat.nat **) +let rec nat_of_pos = function +| One -> Nat.S Nat.O +| P1 ps -> Nat.S (Nat.times (Nat.S (Nat.S Nat.O)) (nat_of_pos ps)) +| P0 ps -> Nat.times (Nat.S (Nat.S Nat.O)) (nat_of_pos ps) + +(** val succ_pos_of_nat : Nat.nat -> pos **) +let rec succ_pos_of_nat = function +| Nat.O -> One +| Nat.S n' -> succ (succ_pos_of_nat n') + +(** val plus : pos -> pos -> pos **) +let rec plus n m = + match n with + | One -> succ m + | P1 n' -> + (match m with + | One -> succ n + | P1 m' -> P0 (succ (plus n' m')) + | P0 m' -> P1 (plus n' m')) + | P0 n' -> + (match m with + | One -> P1 n' + | P1 m' -> P1 (plus n' m') + | P0 m' -> P0 (plus n' m')) + +(** val times : pos -> pos -> pos **) +let rec times n m = + match n with + | One -> m + | P1 n' -> plus m (P0 (times n' m)) + | P0 n' -> P0 (times n' m) + +type minusresult = +| MinusNeg +| MinusZero +| MinusPos of pos + +(** val minusresult_rect_Type4 : + 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 **) +let rec minusresult_rect_Type4 h_MinusNeg h_MinusZero h_MinusPos = function +| MinusNeg -> h_MinusNeg +| MinusZero -> h_MinusZero +| MinusPos x_1813 -> h_MinusPos x_1813 + +(** val minusresult_rect_Type5 : + 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 **) +let rec minusresult_rect_Type5 h_MinusNeg h_MinusZero h_MinusPos = function +| MinusNeg -> h_MinusNeg +| MinusZero -> h_MinusZero +| MinusPos x_1818 -> h_MinusPos x_1818 + +(** val minusresult_rect_Type3 : + 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 **) +let rec minusresult_rect_Type3 h_MinusNeg h_MinusZero h_MinusPos = function +| MinusNeg -> h_MinusNeg +| MinusZero -> h_MinusZero +| MinusPos x_1823 -> h_MinusPos x_1823 + +(** val minusresult_rect_Type2 : + 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 **) +let rec minusresult_rect_Type2 h_MinusNeg h_MinusZero h_MinusPos = function +| MinusNeg -> h_MinusNeg +| MinusZero -> h_MinusZero +| MinusPos x_1828 -> h_MinusPos x_1828 + +(** val minusresult_rect_Type1 : + 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 **) +let rec minusresult_rect_Type1 h_MinusNeg h_MinusZero h_MinusPos = function +| MinusNeg -> h_MinusNeg +| MinusZero -> h_MinusZero +| MinusPos x_1833 -> h_MinusPos x_1833 + +(** val minusresult_rect_Type0 : + 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 **) +let rec minusresult_rect_Type0 h_MinusNeg h_MinusZero h_MinusPos = function +| MinusNeg -> h_MinusNeg +| MinusZero -> h_MinusZero +| MinusPos x_1838 -> h_MinusPos x_1838 + +(** val minusresult_inv_rect_Type4 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 **) +let minusresult_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = minusresult_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val minusresult_inv_rect_Type3 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 **) +let minusresult_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = minusresult_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val minusresult_inv_rect_Type2 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 **) +let minusresult_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = minusresult_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val minusresult_inv_rect_Type1 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 **) +let minusresult_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = minusresult_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val minusresult_inv_rect_Type0 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 **) +let minusresult_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = minusresult_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val minusresult_discr : minusresult -> minusresult -> __ **) +let minusresult_discr x y = + Logic.eq_rect_Type2 x + (match x with + | MinusNeg -> Obj.magic (fun _ dH -> dH) + | MinusZero -> Obj.magic (fun _ dH -> dH) + | MinusPos a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val partial_minus : pos -> pos -> minusresult **) +let rec partial_minus n m = + match n with + | One -> + (match m with + | One -> MinusZero + | P1 x -> MinusNeg + | P0 x -> MinusNeg) + | P1 n' -> + (match m with + | One -> MinusPos (P0 n') + | P1 m' -> + (match partial_minus n' m' with + | MinusNeg -> MinusNeg + | MinusZero -> MinusZero + | MinusPos p -> MinusPos (P0 p)) + | P0 m' -> + (match partial_minus n' m' with + | MinusNeg -> MinusNeg + | MinusZero -> MinusPos One + | MinusPos p -> MinusPos (P1 p))) + | P0 n' -> + (match m with + | One -> MinusPos (pred n) + | P1 m' -> + (match partial_minus n' m' with + | MinusNeg -> MinusNeg + | MinusZero -> MinusNeg + | MinusPos p -> MinusPos (pred (P0 p))) + | P0 m' -> + (match partial_minus n' m' with + | MinusNeg -> MinusNeg + | MinusZero -> MinusZero + | MinusPos p -> MinusPos (P0 p))) + +(** val minus : pos -> pos -> pos **) +let minus n m = + match partial_minus n m with + | MinusNeg -> One + | MinusZero -> One + | MinusPos p -> p + +(** val eqb : pos -> pos -> Bool.bool **) +let rec eqb n m = + match n with + | One -> + (match m with + | One -> Bool.True + | P1 x -> Bool.False + | P0 x -> Bool.False) + | P1 p -> + (match m with + | One -> Bool.False + | P1 q -> eqb p q + | P0 x -> Bool.False) + | P0 p -> + (match m with + | One -> Bool.False + | P1 x -> Bool.False + | P0 q -> eqb p q) + +(** val eqb_elim : pos -> pos -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let eqb_elim n m x x0 = + pos_rect_Type1 (fun m0 -> + match m0 with + | One -> (fun _ auto auto' -> auto __) + | P1 m' -> (fun _ t f -> f __) + | P0 m' -> (fun _ t f -> f __)) (fun n' iH m0 -> + match m0 with + | One -> (fun _ t f -> f __) + | P1 m' -> (fun _ t f -> iH m' __ (fun _ -> t __) (fun _ -> f __)) + | P0 m' -> (fun _ t f -> f __)) (fun n' iH m0 -> + match m0 with + | One -> (fun _ t f -> f __) + | P1 m' -> (fun _ t f -> f __) + | P0 m' -> (fun _ t f -> iH m' __ (fun _ -> t __) (fun _ -> f __))) n m + __ x x0 + +(** val leb : pos -> pos -> Bool.bool **) +let rec leb n m = + match partial_minus n m with + | MinusNeg -> Bool.True + | MinusZero -> Bool.True + | MinusPos x -> Bool.False + +(** val pos_compare : pos -> pos -> compare **) +let pos_compare n m = + match partial_minus n m with + | MinusNeg -> LT + | MinusZero -> EQ + | MinusPos x -> GT + +(** val two_power_nat : Nat.nat -> pos **) +let rec two_power_nat = function +| Nat.O -> One +| Nat.S n' -> P0 (two_power_nat n') + +(** val two_power_pos : pos -> pos **) +let two_power_pos p = + two_power_nat (nat_of_pos p) + +(** val max : pos -> pos -> pos **) +let max n m = + match leb n m with + | Bool.True -> m + | Bool.False -> n + diff --git a/extracted/positive.mli b/extracted/positive.mli new file mode 100644 index 0000000..1b40826 --- /dev/null +++ b/extracted/positive.mli @@ -0,0 +1,158 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Bool + +open Relations + +open Nat + +type compare = +| LT +| EQ +| GT + +val compare_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 + +val compare_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 + +val compare_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 + +val compare_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 + +val compare_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 + +val compare_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> compare -> 'a1 + +val compare_inv_rect_Type4 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val compare_inv_rect_Type3 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val compare_inv_rect_Type2 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val compare_inv_rect_Type1 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val compare_inv_rect_Type0 : + compare -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val compare_discr : compare -> compare -> __ + +val compare_invert : compare -> compare + +type pos = +| One +| P1 of pos +| P0 of pos + +val pos_rect_Type4 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 + +val pos_rect_Type3 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 + +val pos_rect_Type2 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 + +val pos_rect_Type1 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 + +val pos_rect_Type0 : + 'a1 -> (pos -> 'a1 -> 'a1) -> (pos -> 'a1 -> 'a1) -> pos -> 'a1 + +val pos_inv_rect_Type4 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 + +val pos_inv_rect_Type3 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 + +val pos_inv_rect_Type2 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 + +val pos_inv_rect_Type1 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 + +val pos_inv_rect_Type0 : + pos -> (__ -> 'a1) -> (pos -> (__ -> 'a1) -> __ -> 'a1) -> (pos -> (__ -> + 'a1) -> __ -> 'a1) -> 'a1 + +val pos_discr : pos -> pos -> __ + +val pred : pos -> pos + +val succ : pos -> pos + +val nat_of_pos : pos -> Nat.nat + +val succ_pos_of_nat : Nat.nat -> pos + +val plus : pos -> pos -> pos + +val times : pos -> pos -> pos + +type minusresult = +| MinusNeg +| MinusZero +| MinusPos of pos + +val minusresult_rect_Type4 : 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 + +val minusresult_rect_Type5 : 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 + +val minusresult_rect_Type3 : 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 + +val minusresult_rect_Type2 : 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 + +val minusresult_rect_Type1 : 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 + +val minusresult_rect_Type0 : 'a1 -> 'a1 -> (pos -> 'a1) -> minusresult -> 'a1 + +val minusresult_inv_rect_Type4 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 + +val minusresult_inv_rect_Type3 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 + +val minusresult_inv_rect_Type2 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 + +val minusresult_inv_rect_Type1 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 + +val minusresult_inv_rect_Type0 : + minusresult -> (__ -> 'a1) -> (__ -> 'a1) -> (pos -> __ -> 'a1) -> 'a1 + +val minusresult_discr : minusresult -> minusresult -> __ + +val partial_minus : pos -> pos -> minusresult + +val minus : pos -> pos -> pos + +val eqb : pos -> pos -> Bool.bool + +val eqb_elim : pos -> pos -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val leb : pos -> pos -> Bool.bool + +val pos_compare : pos -> pos -> compare + +val two_power_nat : Nat.nat -> pos + +val two_power_pos : pos -> pos + +val max : pos -> pos -> pos + diff --git a/extracted/positiveMap.ml b/extracted/positiveMap.ml new file mode 100644 index 0000000..0d35f89 --- /dev/null +++ b/extracted/positiveMap.ml @@ -0,0 +1,386 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Positive + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open Setoids + +open Monad + +open Option + +type 'a positive_map = +| Pm_leaf +| Pm_node of 'a Types.option * 'a positive_map * 'a positive_map + +(** val positive_map_rect_Type4 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 + -> 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 **) +let rec positive_map_rect_Type4 h_pm_leaf h_pm_node = function +| Pm_leaf -> h_pm_leaf +| Pm_node (x_3300, x_3299, x_3298) -> + h_pm_node x_3300 x_3299 x_3298 + (positive_map_rect_Type4 h_pm_leaf h_pm_node x_3299) + (positive_map_rect_Type4 h_pm_leaf h_pm_node x_3298) + +(** val positive_map_rect_Type3 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 + -> 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 **) +let rec positive_map_rect_Type3 h_pm_leaf h_pm_node = function +| Pm_leaf -> h_pm_leaf +| Pm_node (x_3312, x_3311, x_3310) -> + h_pm_node x_3312 x_3311 x_3310 + (positive_map_rect_Type3 h_pm_leaf h_pm_node x_3311) + (positive_map_rect_Type3 h_pm_leaf h_pm_node x_3310) + +(** val positive_map_rect_Type2 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 + -> 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 **) +let rec positive_map_rect_Type2 h_pm_leaf h_pm_node = function +| Pm_leaf -> h_pm_leaf +| Pm_node (x_3318, x_3317, x_3316) -> + h_pm_node x_3318 x_3317 x_3316 + (positive_map_rect_Type2 h_pm_leaf h_pm_node x_3317) + (positive_map_rect_Type2 h_pm_leaf h_pm_node x_3316) + +(** val positive_map_rect_Type1 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 + -> 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 **) +let rec positive_map_rect_Type1 h_pm_leaf h_pm_node = function +| Pm_leaf -> h_pm_leaf +| Pm_node (x_3324, x_3323, x_3322) -> + h_pm_node x_3324 x_3323 x_3322 + (positive_map_rect_Type1 h_pm_leaf h_pm_node x_3323) + (positive_map_rect_Type1 h_pm_leaf h_pm_node x_3322) + +(** val positive_map_rect_Type0 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 + -> 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 **) +let rec positive_map_rect_Type0 h_pm_leaf h_pm_node = function +| Pm_leaf -> h_pm_leaf +| Pm_node (x_3330, x_3329, x_3328) -> + h_pm_node x_3330 x_3329 x_3328 + (positive_map_rect_Type0 h_pm_leaf h_pm_node x_3329) + (positive_map_rect_Type0 h_pm_leaf h_pm_node x_3328) + +(** val positive_map_inv_rect_Type4 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map + -> 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 **) +let positive_map_inv_rect_Type4 hterm h1 h2 = + let hcut = positive_map_rect_Type4 h1 h2 hterm in hcut __ + +(** val positive_map_inv_rect_Type3 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map + -> 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 **) +let positive_map_inv_rect_Type3 hterm h1 h2 = + let hcut = positive_map_rect_Type3 h1 h2 hterm in hcut __ + +(** val positive_map_inv_rect_Type2 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map + -> 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 **) +let positive_map_inv_rect_Type2 hterm h1 h2 = + let hcut = positive_map_rect_Type2 h1 h2 hterm in hcut __ + +(** val positive_map_inv_rect_Type1 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map + -> 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 **) +let positive_map_inv_rect_Type1 hterm h1 h2 = + let hcut = positive_map_rect_Type1 h1 h2 hterm in hcut __ + +(** val positive_map_inv_rect_Type0 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map + -> 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 **) +let positive_map_inv_rect_Type0 hterm h1 h2 = + let hcut = positive_map_rect_Type0 h1 h2 hterm in hcut __ + +(** val positive_map_discr : 'a1 positive_map -> 'a1 positive_map -> __ **) +let positive_map_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Pm_leaf -> Obj.magic (fun _ dH -> dH) + | Pm_node (a0, a10, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val positive_map_jmdiscr : 'a1 positive_map -> 'a1 positive_map -> __ **) +let positive_map_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Pm_leaf -> Obj.magic (fun _ dH -> dH) + | Pm_node (a0, a10, a2) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val lookup_opt : Positive.pos -> 'a1 positive_map -> 'a1 Types.option **) +let rec lookup_opt b = function +| Pm_leaf -> Types.None +| Pm_node (a, l, r) -> + (match b with + | Positive.One -> a + | Positive.P1 tl -> lookup_opt tl r + | Positive.P0 tl -> lookup_opt tl l) + +(** val lookup : Positive.pos -> 'a1 positive_map -> 'a1 -> 'a1 **) +let lookup b t x = + match lookup_opt b t with + | Types.None -> x + | Types.Some r -> r + +(** val pm_set : + Positive.pos -> 'a1 Types.option -> 'a1 positive_map -> 'a1 positive_map **) +let rec pm_set b a t = + match b with + | Positive.One -> + (match t with + | Pm_leaf -> Pm_node (a, Pm_leaf, Pm_leaf) + | Pm_node (x, l, r) -> Pm_node (a, l, r)) + | Positive.P1 tl -> + (match t with + | Pm_leaf -> Pm_node (Types.None, Pm_leaf, (pm_set tl a Pm_leaf)) + | Pm_node (x, l, r) -> Pm_node (x, l, (pm_set tl a r))) + | Positive.P0 tl -> + (match t with + | Pm_leaf -> Pm_node (Types.None, (pm_set tl a Pm_leaf), Pm_leaf) + | Pm_node (x, l, r) -> Pm_node (x, (pm_set tl a l), r)) + +(** val insert : + Positive.pos -> 'a1 -> 'a1 positive_map -> 'a1 positive_map **) +let insert p a = + pm_set p (Types.Some a) + +(** val update : + Positive.pos -> 'a1 -> 'a1 positive_map -> 'a1 positive_map Types.option **) +let rec update b a t = + match b with + | Positive.One -> + (match t with + | Pm_leaf -> Types.None + | Pm_node (x, l, r) -> + Types.option_map (fun x0 -> Pm_node ((Types.Some a), l, r)) x) + | Positive.P1 tl -> + (match t with + | Pm_leaf -> Types.None + | Pm_node (x, l, r) -> + Types.option_map (fun r0 -> Pm_node (x, l, r0)) (update tl a r)) + | Positive.P0 tl -> + (match t with + | Pm_leaf -> Types.None + | Pm_node (x, l, r) -> + Types.option_map (fun l0 -> Pm_node (x, l0, r)) (update tl a l)) + +(** val fold : + (Positive.pos -> 'a1 -> 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 -> 'a2 **) +let rec fold f t b = + match t with + | Pm_leaf -> b + | Pm_node (a, l, r) -> + let b0 = + match a with + | Types.None -> b + | Types.Some a0 -> f Positive.One a0 b + in + let b1 = fold (fun x -> f (Positive.P0 x)) l b0 in + fold (fun x -> f (Positive.P1 x)) r b1 + +(** val domain_of_pm : 'a1 positive_map -> Types.unit0 positive_map **) +let domain_of_pm t = + fold (fun p a b -> insert p Types.It b) t Pm_leaf + +(** val is_none : 'a1 Types.option -> Bool.bool **) +let is_none = function +| Types.None -> Bool.True +| Types.Some x -> Bool.False + +(** val is_pm_leaf : 'a1 positive_map -> Bool.bool **) +let is_pm_leaf = function +| Pm_leaf -> Bool.True +| Pm_node (x, x0, x1) -> Bool.False + +(** val map_opt : + ('a1 -> 'a2 Types.option) -> 'a1 positive_map -> 'a2 positive_map **) +let rec map_opt f = function +| Pm_leaf -> Pm_leaf +| Pm_node (a, l, r) -> + let a' = + Monad.m_bind0 (Monad.max_def Option.option) (Obj.magic a) (fun x -> + Obj.magic f x) + in + let l' = map_opt f l in + let r' = map_opt f r in + (match Bool.andb (Bool.andb (is_none (Obj.magic a')) (is_pm_leaf l')) + (is_pm_leaf r') with + | Bool.True -> Pm_leaf + | Bool.False -> Pm_node ((Obj.magic a'), l', r')) + +(** val map : ('a1 -> 'a2) -> 'a1 positive_map -> 'a2 positive_map **) +let map f = + map_opt (fun x -> Types.Some (f x)) + +(** val merge : + ('a1 Types.option -> 'a2 Types.option -> 'a3 Types.option) -> 'a1 + positive_map -> 'a2 positive_map -> 'a3 positive_map **) +let rec merge choice a b = + match a with + | Pm_leaf -> map_opt (fun x -> choice Types.None (Types.Some x)) b + | Pm_node (o, l, r) -> + (match b with + | Pm_leaf -> map_opt (fun x -> choice (Types.Some x) Types.None) a + | Pm_node (o', l', r') -> + let o'' = choice o o' in + let l'' = merge choice l l' in + let r'' = merge choice r r' in + (match Bool.andb (Bool.andb (is_none o'') (is_pm_leaf l'')) + (is_pm_leaf r'') with + | Bool.True -> Pm_leaf + | Bool.False -> Pm_node (o'', l'', r''))) + +(** val domain_size : 'a1 positive_map -> Nat.nat **) +let rec domain_size = function +| Pm_leaf -> Nat.O +| Pm_node (a, l, r) -> + Nat.plus + (Nat.plus + (match a with + | Types.None -> Nat.O + | Types.Some x -> Nat.S Nat.O) (domain_size l)) (domain_size r) + +(** val pm_all_aux : + 'a1 positive_map -> 'a1 positive_map -> (Positive.pos -> Positive.pos) -> + (Positive.pos -> 'a1 -> __ -> Bool.bool) -> Bool.bool **) +let rec pm_all_aux m t pre x = + (match t with + | Pm_leaf -> (fun _ x0 -> Bool.True) + | Pm_node (a, l, r) -> + (fun _ f -> + Bool.andb + (Bool.andb (pm_all_aux m l (fun x0 -> pre (Positive.P0 x0)) f) + ((match a with + | Types.None -> (fun _ -> Bool.True) + | Types.Some a' -> (fun _ -> f (pre Positive.One) a' __)) __)) + (pm_all_aux m r (fun x0 -> pre (Positive.P1 x0)) f))) __ x + +(** val pm_all : + 'a1 positive_map -> (Positive.pos -> 'a1 -> __ -> Bool.bool) -> Bool.bool **) +let pm_all m f = + pm_all_aux m m (fun x -> x) f + +(** val pm_choose : + 'a1 positive_map -> ((Positive.pos, 'a1) Types.prod, 'a1 positive_map) + Types.prod Types.option **) +let rec pm_choose = function +| Pm_leaf -> Types.None +| Pm_node (a, l, r) -> + (match pm_choose l with + | Types.None -> + (match pm_choose r with + | Types.None -> + (match a with + | Types.None -> Types.None + | Types.Some a0 -> + Types.Some { Types.fst = { Types.fst = Positive.One; Types.snd = + a0 }; Types.snd = Pm_leaf }) + | Types.Some x -> + Types.Some { Types.fst = { Types.fst = (Positive.P1 + x.Types.fst.Types.fst); Types.snd = x.Types.fst.Types.snd }; + Types.snd = (Pm_node (a, l, x.Types.snd)) }) + | Types.Some x -> + Types.Some { Types.fst = { Types.fst = (Positive.P0 + x.Types.fst.Types.fst); Types.snd = x.Types.fst.Types.snd }; + Types.snd = (Pm_node (a, x.Types.snd, r)) }) + +(** val pm_try_remove : + Positive.pos -> 'a1 positive_map -> ('a1, 'a1 positive_map) Types.prod + Types.option **) +let rec pm_try_remove b t = + match b with + | Positive.One -> + (match t with + | Pm_leaf -> Types.None + | Pm_node (x, l, r) -> + Types.option_map (fun x0 -> { Types.fst = x0; Types.snd = (Pm_node + (Types.None, l, r)) }) x) + | Positive.P1 tl -> + (match t with + | Pm_leaf -> Types.None + | Pm_node (x, l, r) -> + Types.option_map (fun xr -> { Types.fst = xr.Types.fst; Types.snd = + (Pm_node (x, l, xr.Types.snd)) }) (pm_try_remove tl r)) + | Positive.P0 tl -> + (match t with + | Pm_leaf -> Types.None + | Pm_node (x, l, r) -> + Types.option_map (fun xl -> { Types.fst = xl.Types.fst; Types.snd = + (Pm_node (x, xl.Types.snd, r)) }) (pm_try_remove tl l)) + +(** val pm_fold_inf_aux : + 'a1 positive_map -> (Positive.pos -> 'a1 -> __ -> 'a2 -> 'a2) -> 'a1 + positive_map -> (Positive.pos -> Positive.pos) -> 'a2 -> 'a2 **) +let rec pm_fold_inf_aux t f t' pre b = + (match t' with + | Pm_leaf -> (fun _ -> b) + | Pm_node (a, l, r) -> + (fun _ -> + let b0 = + (match a with + | Types.None -> (fun _ -> b) + | Types.Some a0 -> (fun _ -> f (pre Positive.One) a0 __ b)) __ + in + let b1 = pm_fold_inf_aux t f l (fun x -> pre (Positive.P0 x)) b0 in + pm_fold_inf_aux t f r (fun x -> pre (Positive.P1 x)) b1)) __ + +(** val pm_fold_inf : + 'a1 positive_map -> (Positive.pos -> 'a1 -> __ -> 'a2 -> 'a2) -> 'a2 -> + 'a2 **) +let pm_fold_inf t f b = + pm_fold_inf_aux t f t (fun x -> x) b + +(** val pm_find_aux : + (Positive.pos -> Positive.pos) -> 'a1 positive_map -> (Positive.pos -> + 'a1 -> Bool.bool) -> (Positive.pos, 'a1) Types.prod Types.option **) +let rec pm_find_aux pre t p = + match t with + | Pm_leaf -> Types.None + | Pm_node (a, l, r) -> + let x = + match a with + | Types.None -> Types.None + | Types.Some a0 -> + (match p (pre Positive.One) a0 with + | Bool.True -> + Types.Some { Types.fst = (pre Positive.One); Types.snd = a0 } + | Bool.False -> Types.None) + in + (match x with + | Types.None -> + (match pm_find_aux (fun x0 -> pre (Positive.P0 x0)) l p with + | Types.None -> pm_find_aux (fun x0 -> pre (Positive.P1 x0)) r p + | Types.Some y -> Types.Some y) + | Types.Some x0 -> Types.Some x0) + +(** val pm_find : + 'a1 positive_map -> (Positive.pos -> 'a1 -> Bool.bool) -> (Positive.pos, + 'a1) Types.prod Types.option **) +let pm_find x x0 = + pm_find_aux (fun x1 -> x1) x x0 + diff --git a/extracted/positiveMap.mli b/extracted/positiveMap.mli new file mode 100644 index 0000000..cf8e93c --- /dev/null +++ b/extracted/positiveMap.mli @@ -0,0 +1,146 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Positive + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open Setoids + +open Monad + +open Option + +type 'a positive_map = +| Pm_leaf +| Pm_node of 'a Types.option * 'a positive_map * 'a positive_map + +val positive_map_rect_Type4 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 -> + 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 + +val positive_map_rect_Type3 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 -> + 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 + +val positive_map_rect_Type2 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 -> + 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 + +val positive_map_rect_Type1 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 -> + 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 + +val positive_map_rect_Type0 : + 'a2 -> ('a1 Types.option -> 'a1 positive_map -> 'a1 positive_map -> 'a2 -> + 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 + +val positive_map_inv_rect_Type4 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map -> + 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 + +val positive_map_inv_rect_Type3 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map -> + 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 + +val positive_map_inv_rect_Type2 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map -> + 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 + +val positive_map_inv_rect_Type1 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map -> + 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 + +val positive_map_inv_rect_Type0 : + 'a1 positive_map -> (__ -> 'a2) -> ('a1 Types.option -> 'a1 positive_map -> + 'a1 positive_map -> (__ -> 'a2) -> (__ -> 'a2) -> __ -> 'a2) -> 'a2 + +val positive_map_discr : 'a1 positive_map -> 'a1 positive_map -> __ + +val positive_map_jmdiscr : 'a1 positive_map -> 'a1 positive_map -> __ + +val lookup_opt : Positive.pos -> 'a1 positive_map -> 'a1 Types.option + +val lookup : Positive.pos -> 'a1 positive_map -> 'a1 -> 'a1 + +val pm_set : + Positive.pos -> 'a1 Types.option -> 'a1 positive_map -> 'a1 positive_map + +val insert : Positive.pos -> 'a1 -> 'a1 positive_map -> 'a1 positive_map + +val update : + Positive.pos -> 'a1 -> 'a1 positive_map -> 'a1 positive_map Types.option + +val fold : + (Positive.pos -> 'a1 -> 'a2 -> 'a2) -> 'a1 positive_map -> 'a2 -> 'a2 + +val domain_of_pm : 'a1 positive_map -> Types.unit0 positive_map + +val is_none : 'a1 Types.option -> Bool.bool + +val is_pm_leaf : 'a1 positive_map -> Bool.bool + +val map_opt : + ('a1 -> 'a2 Types.option) -> 'a1 positive_map -> 'a2 positive_map + +val map : ('a1 -> 'a2) -> 'a1 positive_map -> 'a2 positive_map + +val merge : + ('a1 Types.option -> 'a2 Types.option -> 'a3 Types.option) -> 'a1 + positive_map -> 'a2 positive_map -> 'a3 positive_map + +val domain_size : 'a1 positive_map -> Nat.nat + +val pm_all_aux : + 'a1 positive_map -> 'a1 positive_map -> (Positive.pos -> Positive.pos) -> + (Positive.pos -> 'a1 -> __ -> Bool.bool) -> Bool.bool + +val pm_all : + 'a1 positive_map -> (Positive.pos -> 'a1 -> __ -> Bool.bool) -> Bool.bool + +val pm_choose : + 'a1 positive_map -> ((Positive.pos, 'a1) Types.prod, 'a1 positive_map) + Types.prod Types.option + +val pm_try_remove : + Positive.pos -> 'a1 positive_map -> ('a1, 'a1 positive_map) Types.prod + Types.option + +val pm_fold_inf_aux : + 'a1 positive_map -> (Positive.pos -> 'a1 -> __ -> 'a2 -> 'a2) -> 'a1 + positive_map -> (Positive.pos -> Positive.pos) -> 'a2 -> 'a2 + +val pm_fold_inf : + 'a1 positive_map -> (Positive.pos -> 'a1 -> __ -> 'a2 -> 'a2) -> 'a2 -> 'a2 + +val pm_find_aux : + (Positive.pos -> Positive.pos) -> 'a1 positive_map -> (Positive.pos -> 'a1 + -> Bool.bool) -> (Positive.pos, 'a1) Types.prod Types.option + +val pm_find : + 'a1 positive_map -> (Positive.pos -> 'a1 -> Bool.bool) -> (Positive.pos, + 'a1) Types.prod Types.option + diff --git a/extracted/preIdentifiers.ml b/extracted/preIdentifiers.ml new file mode 100644 index 0000000..53bc093 --- /dev/null +++ b/extracted/preIdentifiers.ml @@ -0,0 +1,193 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Positive + +type identifierTag = +| Label +| CostTag +| RegisterTag +| LabelTag +| SymbolTag +| ASMTag + +(** val identifierTag_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 **) +let rec identifierTag_rect_Type4 h_Label h_CostTag h_RegisterTag h_LabelTag h_SymbolTag h_ASMTag = function +| Label -> h_Label +| CostTag -> h_CostTag +| RegisterTag -> h_RegisterTag +| LabelTag -> h_LabelTag +| SymbolTag -> h_SymbolTag +| ASMTag -> h_ASMTag + +(** val identifierTag_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 **) +let rec identifierTag_rect_Type5 h_Label h_CostTag h_RegisterTag h_LabelTag h_SymbolTag h_ASMTag = function +| Label -> h_Label +| CostTag -> h_CostTag +| RegisterTag -> h_RegisterTag +| LabelTag -> h_LabelTag +| SymbolTag -> h_SymbolTag +| ASMTag -> h_ASMTag + +(** val identifierTag_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 **) +let rec identifierTag_rect_Type3 h_Label h_CostTag h_RegisterTag h_LabelTag h_SymbolTag h_ASMTag = function +| Label -> h_Label +| CostTag -> h_CostTag +| RegisterTag -> h_RegisterTag +| LabelTag -> h_LabelTag +| SymbolTag -> h_SymbolTag +| ASMTag -> h_ASMTag + +(** val identifierTag_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 **) +let rec identifierTag_rect_Type2 h_Label h_CostTag h_RegisterTag h_LabelTag h_SymbolTag h_ASMTag = function +| Label -> h_Label +| CostTag -> h_CostTag +| RegisterTag -> h_RegisterTag +| LabelTag -> h_LabelTag +| SymbolTag -> h_SymbolTag +| ASMTag -> h_ASMTag + +(** val identifierTag_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 **) +let rec identifierTag_rect_Type1 h_Label h_CostTag h_RegisterTag h_LabelTag h_SymbolTag h_ASMTag = function +| Label -> h_Label +| CostTag -> h_CostTag +| RegisterTag -> h_RegisterTag +| LabelTag -> h_LabelTag +| SymbolTag -> h_SymbolTag +| ASMTag -> h_ASMTag + +(** val identifierTag_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 **) +let rec identifierTag_rect_Type0 h_Label h_CostTag h_RegisterTag h_LabelTag h_SymbolTag h_ASMTag = function +| Label -> h_Label +| CostTag -> h_CostTag +| RegisterTag -> h_RegisterTag +| LabelTag -> h_LabelTag +| SymbolTag -> h_SymbolTag +| ASMTag -> h_ASMTag + +(** val identifierTag_inv_rect_Type4 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let identifierTag_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = identifierTag_rect_Type4 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val identifierTag_inv_rect_Type3 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let identifierTag_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 = + let hcut = identifierTag_rect_Type3 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val identifierTag_inv_rect_Type2 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let identifierTag_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 = + let hcut = identifierTag_rect_Type2 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val identifierTag_inv_rect_Type1 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let identifierTag_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 = + let hcut = identifierTag_rect_Type1 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val identifierTag_inv_rect_Type0 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let identifierTag_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 = + let hcut = identifierTag_rect_Type0 h1 h2 h3 h4 h5 h6 hterm in hcut __ + +(** val identifierTag_discr : identifierTag -> identifierTag -> __ **) +let identifierTag_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Label -> Obj.magic (fun _ dH -> dH) + | CostTag -> Obj.magic (fun _ dH -> dH) + | RegisterTag -> Obj.magic (fun _ dH -> dH) + | LabelTag -> Obj.magic (fun _ dH -> dH) + | SymbolTag -> Obj.magic (fun _ dH -> dH) + | ASMTag -> Obj.magic (fun _ dH -> dH)) y + +type identifier = + Positive.pos + (* singleton inductive, whose constructor was an_identifier *) + +(** val identifier_rect_Type4 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 **) +let rec identifier_rect_Type4 tag h_an_identifier x_2070 = + let x_2071 = x_2070 in h_an_identifier x_2071 + +(** val identifier_rect_Type5 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 **) +let rec identifier_rect_Type5 tag h_an_identifier x_2073 = + let x_2074 = x_2073 in h_an_identifier x_2074 + +(** val identifier_rect_Type3 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 **) +let rec identifier_rect_Type3 tag h_an_identifier x_2076 = + let x_2077 = x_2076 in h_an_identifier x_2077 + +(** val identifier_rect_Type2 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 **) +let rec identifier_rect_Type2 tag h_an_identifier x_2079 = + let x_2080 = x_2079 in h_an_identifier x_2080 + +(** val identifier_rect_Type1 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 **) +let rec identifier_rect_Type1 tag h_an_identifier x_2082 = + let x_2083 = x_2082 in h_an_identifier x_2083 + +(** val identifier_rect_Type0 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 **) +let rec identifier_rect_Type0 tag h_an_identifier x_2085 = + let x_2086 = x_2085 in h_an_identifier x_2086 + +(** val identifier_inv_rect_Type4 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let identifier_inv_rect_Type4 x1 hterm h1 = + let hcut = identifier_rect_Type4 x1 h1 hterm in hcut __ + +(** val identifier_inv_rect_Type3 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let identifier_inv_rect_Type3 x1 hterm h1 = + let hcut = identifier_rect_Type3 x1 h1 hterm in hcut __ + +(** val identifier_inv_rect_Type2 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let identifier_inv_rect_Type2 x1 hterm h1 = + let hcut = identifier_rect_Type2 x1 h1 hterm in hcut __ + +(** val identifier_inv_rect_Type1 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let identifier_inv_rect_Type1 x1 hterm h1 = + let hcut = identifier_rect_Type1 x1 h1 hterm in hcut __ + +(** val identifier_inv_rect_Type0 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 **) +let identifier_inv_rect_Type0 x1 hterm h1 = + let hcut = identifier_rect_Type0 x1 h1 hterm in hcut __ + +(** val identifier_discr : + identifierTag -> identifier -> identifier -> __ **) +let identifier_discr a1 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __)) y + diff --git a/extracted/preIdentifiers.mli b/extracted/preIdentifiers.mli new file mode 100644 index 0000000..b16cc8a --- /dev/null +++ b/extracted/preIdentifiers.mli @@ -0,0 +1,107 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Bool + +open Relations + +open Nat + +open Positive + +type identifierTag = +| Label +| CostTag +| RegisterTag +| LabelTag +| SymbolTag +| ASMTag + +val identifierTag_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 + +val identifierTag_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 + +val identifierTag_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 + +val identifierTag_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 + +val identifierTag_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 + +val identifierTag_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> identifierTag -> 'a1 + +val identifierTag_inv_rect_Type4 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val identifierTag_inv_rect_Type3 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val identifierTag_inv_rect_Type2 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val identifierTag_inv_rect_Type1 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val identifierTag_inv_rect_Type0 : + identifierTag -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val identifierTag_discr : identifierTag -> identifierTag -> __ + +type identifier = + Positive.pos + (* singleton inductive, whose constructor was an_identifier *) + +val identifier_rect_Type4 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 + +val identifier_rect_Type5 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 + +val identifier_rect_Type3 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 + +val identifier_rect_Type2 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 + +val identifier_rect_Type1 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 + +val identifier_rect_Type0 : + identifierTag -> (Positive.pos -> 'a1) -> identifier -> 'a1 + +val identifier_inv_rect_Type4 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val identifier_inv_rect_Type3 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val identifier_inv_rect_Type2 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val identifier_inv_rect_Type1 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val identifier_inv_rect_Type0 : + identifierTag -> identifier -> (Positive.pos -> __ -> 'a1) -> 'a1 + +val identifier_discr : identifierTag -> identifier -> identifier -> __ + diff --git a/extracted/preamble.ml b/extracted/preamble.ml new file mode 100644 index 0000000..e1a25e1 --- /dev/null +++ b/extracted/preamble.ml @@ -0,0 +1,2 @@ +type __ = Obj.t +let __ = let rec f _ = Obj.repr f in Obj.repr f diff --git a/extracted/proper.ml b/extracted/proper.ml new file mode 100644 index 0000000..07e66b0 --- /dev/null +++ b/extracted/proper.ml @@ -0,0 +1,12 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + diff --git a/extracted/proper.mli b/extracted/proper.mli new file mode 100644 index 0000000..07e66b0 --- /dev/null +++ b/extracted/proper.mli @@ -0,0 +1,12 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + diff --git a/extracted/pts.ml b/extracted/pts.ml new file mode 100644 index 0000000..40ed946 --- /dev/null +++ b/extracted/pts.ml @@ -0,0 +1,4 @@ +open Preamble + +open Core_notation + diff --git a/extracted/pts.mli b/extracted/pts.mli new file mode 100644 index 0000000..40ed946 --- /dev/null +++ b/extracted/pts.mli @@ -0,0 +1,4 @@ +open Preamble + +open Core_notation + diff --git a/extracted/rTL.ml b/extracted/rTL.ml new file mode 100644 index 0000000..b5674c2 --- /dev/null +++ b/extracted/rTL.ml @@ -0,0 +1,325 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type rtl_seq = +| Rtl_stack_address of Registers.register * Registers.register + +(** val rtl_seq_rect_Type4 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 **) +let rec rtl_seq_rect_Type4 h_rtl_stack_address = function +| Rtl_stack_address (x_18151, x_18150) -> h_rtl_stack_address x_18151 x_18150 + +(** val rtl_seq_rect_Type5 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 **) +let rec rtl_seq_rect_Type5 h_rtl_stack_address = function +| Rtl_stack_address (x_18155, x_18154) -> h_rtl_stack_address x_18155 x_18154 + +(** val rtl_seq_rect_Type3 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 **) +let rec rtl_seq_rect_Type3 h_rtl_stack_address = function +| Rtl_stack_address (x_18159, x_18158) -> h_rtl_stack_address x_18159 x_18158 + +(** val rtl_seq_rect_Type2 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 **) +let rec rtl_seq_rect_Type2 h_rtl_stack_address = function +| Rtl_stack_address (x_18163, x_18162) -> h_rtl_stack_address x_18163 x_18162 + +(** val rtl_seq_rect_Type1 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 **) +let rec rtl_seq_rect_Type1 h_rtl_stack_address = function +| Rtl_stack_address (x_18167, x_18166) -> h_rtl_stack_address x_18167 x_18166 + +(** val rtl_seq_rect_Type0 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 **) +let rec rtl_seq_rect_Type0 h_rtl_stack_address = function +| Rtl_stack_address (x_18171, x_18170) -> h_rtl_stack_address x_18171 x_18170 + +(** val rtl_seq_inv_rect_Type4 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 **) +let rtl_seq_inv_rect_Type4 hterm h1 = + let hcut = rtl_seq_rect_Type4 h1 hterm in hcut __ + +(** val rtl_seq_inv_rect_Type3 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 **) +let rtl_seq_inv_rect_Type3 hterm h1 = + let hcut = rtl_seq_rect_Type3 h1 hterm in hcut __ + +(** val rtl_seq_inv_rect_Type2 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 **) +let rtl_seq_inv_rect_Type2 hterm h1 = + let hcut = rtl_seq_rect_Type2 h1 hterm in hcut __ + +(** val rtl_seq_inv_rect_Type1 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 **) +let rtl_seq_inv_rect_Type1 hterm h1 = + let hcut = rtl_seq_rect_Type1 h1 hterm in hcut __ + +(** val rtl_seq_inv_rect_Type0 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 **) +let rtl_seq_inv_rect_Type0 hterm h1 = + let hcut = rtl_seq_rect_Type0 h1 hterm in hcut __ + +(** val rtl_seq_discr : rtl_seq -> rtl_seq -> __ **) +let rtl_seq_discr x y = + Logic.eq_rect_Type2 x + (let Rtl_stack_address (a0, a1) = x in Obj.magic (fun _ dH -> dH __ __)) + y + +(** val rtl_seq_jmdiscr : rtl_seq -> rtl_seq -> __ **) +let rtl_seq_jmdiscr x y = + Logic.eq_rect_Type2 x + (let Rtl_stack_address (a0, a1) = x in Obj.magic (fun _ dH -> dH __ __)) + y + +(** val rTL_uns : Joint.unserialized_params **) +let rTL_uns = + { Joint.ext_seq_labels = (fun x -> List.Nil); Joint.has_tailcalls = + Bool.False } + +(** val rTL_functs : Joint.get_pseudo_reg_functs **) +let rTL_functs = + { Joint.acc_a_regs = (fun r -> List.Cons ((Obj.magic r), List.Nil)); + Joint.acc_b_regs = (fun r -> List.Cons ((Obj.magic r), List.Nil)); + Joint.acc_a_args = (fun a -> + match Obj.magic a with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.acc_b_args = (fun a -> + match Obj.magic a with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.dpl_regs = (fun r -> List.Cons + ((Obj.magic r), List.Nil)); Joint.dph_regs = (fun r -> List.Cons + ((Obj.magic r), List.Nil)); Joint.dpl_args = (fun a -> + match Obj.magic a with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.dph_args = (fun a -> + match Obj.magic a with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.snd_args = (fun a -> + match Obj.magic a with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil); Joint.pair_move_regs = (fun x -> + List.append (List.Cons ((Obj.magic x).Types.fst, List.Nil)) + (match (Obj.magic x).Types.snd with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x0 -> List.Nil)); Joint.f_call_args = (fun l -> + Util.foldl (fun l1 a -> + List.append l1 + (match a with + | Joint.Reg r -> List.Cons (r, List.Nil) + | Joint.Imm x -> List.Nil)) List.Nil (Obj.magic l)); + Joint.f_call_dest = (fun x -> Obj.magic x); Joint.ext_seq_regs = + (fun ext -> + let Rtl_stack_address (r1, r2) = Obj.magic ext in + List.Cons (r1, (List.Cons (r2, List.Nil)))); Joint.params_regs = + (fun x -> Obj.magic x) } + +(** val rTL : Joint.graph_params **) +let rTL = + { Joint.u_pars = rTL_uns; Joint.functs = rTL_functs } + +type rtl_program = Joint.joint_program + +(** val dpi1__o__reg_to_rtl_snd_argument__o__inject : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 **) +let dpi1__o__reg_to_rtl_snd_argument__o__inject x2 = + Joint.psd_argument_from_reg x2.Types.dpi1 + +(** val eject__o__reg_to_rtl_snd_argument__o__inject : + Registers.register Types.sig0 -> Joint.psd_argument Types.sig0 **) +let eject__o__reg_to_rtl_snd_argument__o__inject x2 = + Joint.psd_argument_from_reg (Types.pi1 x2) + +(** val reg_to_rtl_snd_argument__o__inject : + Registers.register -> Joint.psd_argument Types.sig0 **) +let reg_to_rtl_snd_argument__o__inject x1 = + Joint.psd_argument_from_reg x1 + +(** val dpi1__o__reg_to_rtl_snd_argument : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument **) +let dpi1__o__reg_to_rtl_snd_argument x1 = + Joint.psd_argument_from_reg x1.Types.dpi1 + +(** val eject__o__reg_to_rtl_snd_argument : + Registers.register Types.sig0 -> Joint.psd_argument **) +let eject__o__reg_to_rtl_snd_argument x1 = + Joint.psd_argument_from_reg (Types.pi1 x1) + +(** val dpi1__o__byte_to_rtl_snd_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 **) +let dpi1__o__byte_to_rtl_snd_argument__o__inject x2 = + Joint.psd_argument_from_byte x2.Types.dpi1 + +(** val eject__o__byte_to_rtl_snd_argument__o__inject : + BitVector.byte Types.sig0 -> Joint.psd_argument Types.sig0 **) +let eject__o__byte_to_rtl_snd_argument__o__inject x2 = + Joint.psd_argument_from_byte (Types.pi1 x2) + +(** val byte_to_rtl_snd_argument__o__inject : + BitVector.byte -> Joint.psd_argument Types.sig0 **) +let byte_to_rtl_snd_argument__o__inject x1 = + Joint.psd_argument_from_byte x1 + +(** val dpi1__o__byte_to_rtl_snd_argument : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument **) +let dpi1__o__byte_to_rtl_snd_argument x1 = + Joint.psd_argument_from_byte x1.Types.dpi1 + +(** val eject__o__byte_to_rtl_snd_argument : + BitVector.byte Types.sig0 -> Joint.psd_argument **) +let eject__o__byte_to_rtl_snd_argument x1 = + Joint.psd_argument_from_byte (Types.pi1 x1) + +(** val rTL_premain : rtl_program -> Joint.joint_closed_internal_function **) +let rTL_premain p = + let l1 = Positive.One in + let l2 = Positive.P0 Positive.One in + let l3 = Positive.P1 Positive.One in + let rs = List.Cons (Positive.One, (List.Cons ((Positive.P0 Positive.One), + (List.Cons ((Positive.P1 Positive.One), (List.Cons ((Positive.P0 + (Positive.P0 Positive.One)), List.Nil))))))) + in + let res = { Joint.joint_if_luniverse = (Positive.P0 (Positive.P0 + Positive.One)); Joint.joint_if_runiverse = (Positive.P1 (Positive.P0 + Positive.One)); Joint.joint_if_result = (Obj.magic List.Nil); + Joint.joint_if_params = (Obj.magic rs); Joint.joint_if_stacksize = Nat.O; + Joint.joint_if_local_stacksize = Nat.O; Joint.joint_if_code = + (Obj.magic (Identifiers.empty_map PreIdentifiers.LabelTag)); + Joint.joint_if_entry = (Obj.magic l1) } + in + let res0 = + Joint.add_graph rTL + (Joint.prog_names (Joint.graph_params_to_params rTL) p) l1 + (Joint.Sequential ((Joint.COST_LABEL p.Joint.init_cost_label), + (Obj.magic l2))) res + in + let res1 = + Joint.add_graph rTL + (Joint.prog_names (Joint.graph_params_to_params rTL) p) l2 + (Joint.Sequential ((Joint.CALL ((Types.Inl + p.Joint.joint_prog.AST.prog_main), (Obj.magic List.Nil), + (Obj.magic rs))), (Obj.magic l3))) res0 + in + let res2 = + Joint.add_graph rTL + (Joint.prog_names (Joint.graph_params_to_params rTL) p) l3 (Joint.Final + (Joint.GOTO l3)) res1 + in + res2 + diff --git a/extracted/rTL.mli b/extracted/rTL.mli new file mode 100644 index 0000000..1dd0242 --- /dev/null +++ b/extracted/rTL.mli @@ -0,0 +1,200 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +type rtl_seq = +| Rtl_stack_address of Registers.register * Registers.register + +val rtl_seq_rect_Type4 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 + +val rtl_seq_rect_Type5 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 + +val rtl_seq_rect_Type3 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 + +val rtl_seq_rect_Type2 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 + +val rtl_seq_rect_Type1 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 + +val rtl_seq_rect_Type0 : + (Registers.register -> Registers.register -> 'a1) -> rtl_seq -> 'a1 + +val rtl_seq_inv_rect_Type4 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 + +val rtl_seq_inv_rect_Type3 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 + +val rtl_seq_inv_rect_Type2 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 + +val rtl_seq_inv_rect_Type1 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 + +val rtl_seq_inv_rect_Type0 : + rtl_seq -> (Registers.register -> Registers.register -> __ -> 'a1) -> 'a1 + +val rtl_seq_discr : rtl_seq -> rtl_seq -> __ + +val rtl_seq_jmdiscr : rtl_seq -> rtl_seq -> __ + +val rTL_uns : Joint.unserialized_params + +val rTL_functs : Joint.get_pseudo_reg_functs + +val rTL : Joint.graph_params + +type rtl_program = Joint.joint_program + +val dpi1__o__reg_to_rtl_snd_argument__o__inject : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 + +val eject__o__reg_to_rtl_snd_argument__o__inject : + Registers.register Types.sig0 -> Joint.psd_argument Types.sig0 + +val reg_to_rtl_snd_argument__o__inject : + Registers.register -> Joint.psd_argument Types.sig0 + +val dpi1__o__reg_to_rtl_snd_argument : + (Registers.register, 'a1) Types.dPair -> Joint.psd_argument + +val eject__o__reg_to_rtl_snd_argument : + Registers.register Types.sig0 -> Joint.psd_argument + +val dpi1__o__byte_to_rtl_snd_argument__o__inject : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument Types.sig0 + +val eject__o__byte_to_rtl_snd_argument__o__inject : + BitVector.byte Types.sig0 -> Joint.psd_argument Types.sig0 + +val byte_to_rtl_snd_argument__o__inject : + BitVector.byte -> Joint.psd_argument Types.sig0 + +val dpi1__o__byte_to_rtl_snd_argument : + (BitVector.byte, 'a1) Types.dPair -> Joint.psd_argument + +val eject__o__byte_to_rtl_snd_argument : + BitVector.byte Types.sig0 -> Joint.psd_argument + +val rTL_premain : rtl_program -> Joint.joint_closed_internal_function + diff --git a/extracted/rTLToERTL.ml b/extracted/rTLToERTL.ml new file mode 100644 index 0000000..f959460 --- /dev/null +++ b/extracted/rTLToERTL.ml @@ -0,0 +1,512 @@ +open Preamble + +open Order + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Registers + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open BitVector + +open Arithmetic + +open Jmeq + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open I8051 + +open RegisterSet + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open CostLabel + +open Hide + +open Integers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open RTL + +open ERTL + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +(** val save_hdws : + AST.ident List.list -> (Registers.register, I8051.register) Types.prod + List.list -> Joint.joint_seq List.list **) +let save_hdws globals = + let save_hdws_internal = fun destr_srcr -> Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD destr_srcr.Types.fst); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW destr_srcr.Types.snd)) }) + in + List.map save_hdws_internal + +(** val restore_hdws : + AST.ident List.list -> (Joint.psd_argument, I8051.register) Types.prod + List.list -> Joint.joint_seq List.list **) +let restore_hdws globals = + let restore_hdws_internal = fun destr_srcr -> Joint.MOVE + (Obj.magic { Types.fst = (ERTL.HDW destr_srcr.Types.snd); Types.snd = + (ERTL.psd_argument_move_src destr_srcr.Types.fst) }) + in + List.map restore_hdws_internal + +(** val get_params_hdw : + AST.ident List.list -> Registers.register List.list -> Joint.joint_seq + List.list **) +let get_params_hdw globals params = + save_hdws globals (Util.zip_pottier params I8051.registerParams) + +(** val get_param_stack : + AST.ident List.list -> Registers.register -> Registers.register -> + Registers.register -> Joint.joint_seq List.list **) +let get_param_stack globals addr1 addr2 destr = + List.Cons ((Joint.LOAD ((Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_reg addr1)), + (Obj.magic (Joint.psd_argument_from_reg addr2)))), (List.Cons ((Joint.OP2 + (BackEndOps.Add, (Obj.magic addr1), + (Obj.magic (Joint.psd_argument_from_reg addr1)), + (let x = I8051.int_size in Obj.magic (Joint.psd_argument_from_byte x)))), + (List.Cons ((Joint.OP2 (BackEndOps.Addc, (Obj.magic addr2), + (Obj.magic (Joint.psd_argument_from_reg addr2)), + (Obj.magic (Joint.psd_argument_from_byte Joint.zero_byte)))), + List.Nil))))) + +(** val get_params_stack : + AST.ident List.list -> Registers.register -> Registers.register -> + Registers.register -> Registers.register List.list -> Joint.joint_seq + List.list **) +let get_params_stack globals tmpr addr1 addr2 params = + let params_length_byte = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (List.length params) + in + List.append (List.Cons + ((let x = + ERTL.ertl_seq_joint globals (Obj.magic (ERTL.Ertl_frame_size tmpr)) + in + x), (List.Cons (Joint.CLEAR_CARRY, (List.Cons ((Joint.OP2 + (BackEndOps.Sub, (Obj.magic tmpr), + (Obj.magic (Joint.psd_argument_from_reg tmpr)), + (Obj.magic (Joint.psd_argument_from_byte params_length_byte)))), + (List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD addr1); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW I8051.registerSPL)) })), (List.Cons + ((Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD addr2); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW I8051.registerSPH)) })), (List.Cons + ((Joint.OP2 (BackEndOps.Add, (Obj.magic addr1), + (Obj.magic (Joint.psd_argument_from_reg addr1)), + (Obj.magic (Joint.psd_argument_from_reg tmpr)))), (List.Cons ((Joint.OP2 + (BackEndOps.Addc, (Obj.magic addr2), + (Obj.magic (Joint.psd_argument_from_reg addr2)), + (Obj.magic (Joint.psd_argument_from_byte Joint.zero_byte)))), + List.Nil)))))))))))))) + (List.flatten (List.map (get_param_stack globals addr1 addr2) params)) + +(** val get_params : + AST.ident List.list -> Registers.register -> Registers.register -> + Registers.register -> Registers.register List.list -> Joint.joint_seq + List.list **) +let get_params globals tmpr addr1 addr2 params = + let n = Nat.min (List.length params) (List.length I8051.registerParams) in + let { Types.fst = hdw_params; Types.snd = stack_params } = + Util.list_split n params + in + List.append (get_params_hdw globals hdw_params) + (get_params_stack globals tmpr addr1 addr2 stack_params) + +(** val save_return : + AST.ident List.list -> Joint.psd_argument List.list -> Joint.joint_seq + List.list **) +let save_return globals ret_regs = + let crl = Util.reduce_strong I8051.registerSTS ret_regs in + let commonl = crl.Types.fst.Types.fst in + let commonr = crl.Types.snd.Types.fst in + let restl = crl.Types.fst.Types.snd in + List.append + (Util.map2 (fun st r -> Joint.MOVE + (Obj.magic { Types.fst = (ERTL.HDW st); Types.snd = + (ERTL.psd_argument_move_src r) })) commonl commonr) + (List.map (fun st -> Joint.MOVE + (Obj.magic { Types.fst = (ERTL.HDW st); Types.snd = + (ERTL.byte_to_ertl_snd_argument__o__psd_argument_to_move_src + Joint.zero_byte) })) restl) + +(** val assign_result : AST.ident List.list -> Joint.joint_seq List.list **) +let assign_result globals = + let crl = Util.reduce_strong I8051.registerRets I8051.registerSTS in + let commonl = crl.Types.fst.Types.fst in + let commonr = crl.Types.snd.Types.fst in + Util.map2 (fun ret st -> Joint.MOVE + (Obj.magic { Types.fst = (ERTL.HDW ret); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW st)) })) commonl commonr + +(** val epilogue : + AST.ident List.list -> Registers.register List.list -> Registers.register + -> Registers.register -> (Registers.register, I8051.register) Types.prod + List.list -> Joint.joint_seq List.list Types.sig0 **) +let epilogue globals ret_regs sral srah sregs = + List.append + (save_return globals (List.map (fun x -> Joint.Reg x) ret_regs)) + (List.append + (restore_hdws globals + (List.map (fun pr -> { Types.fst = (Joint.Reg pr.Types.fst); + Types.snd = pr.Types.snd }) sregs)) + (List.append (List.Cons ((Joint.PUSH + (Obj.magic (Joint.psd_argument_from_reg sral))), (List.Cons + ((Joint.PUSH (Obj.magic (Joint.psd_argument_from_reg srah))), + (List.Cons + ((ERTL.ertl_seq_joint globals (Obj.magic ERTL.Ertl_del_frame)), + List.Nil)))))) (assign_result globals))) + +(** val prologue : + AST.ident List.list -> Registers.register List.list -> Registers.register + -> Registers.register -> Registers.register -> Registers.register -> + Registers.register -> (Registers.register, I8051.register) Types.prod + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new **) +let prologue globals params sral srah tmpr addr1 addr2 sregs = + let l = + List.append (List.Cons + ((let x = ERTL.ertl_seq_joint globals (Obj.magic ERTL.Ertl_new_frame) + in + x), (List.Cons ((Joint.POP (Obj.magic srah)), (List.Cons ((Joint.POP + (Obj.magic sral)), List.Nil)))))) + (List.append (save_hdws globals sregs) + (get_params globals tmpr addr1 addr2 params)) + in + Bind_new.Bret l + +(** val set_params_hdw : + AST.ident List.list -> Joint.psd_argument List.list -> Joint.joint_seq + List.list **) +let set_params_hdw globals params = + restore_hdws globals (Util.zip_pottier params I8051.registerParams) + +(** val set_param_stack : + AST.ident List.list -> Registers.register -> Registers.register -> + Joint.psd_argument -> Joint.joint_seq List.list **) +let set_param_stack globals addr1 addr2 arg = + List.Cons ((Joint.STORE ((Obj.magic (Joint.psd_argument_from_reg addr1)), + (Obj.magic (Joint.psd_argument_from_reg addr2)), (Obj.magic arg))), + (List.Cons ((Joint.OP2 (BackEndOps.Add, (Obj.magic addr1), + (Obj.magic (Joint.psd_argument_from_reg addr1)), + (let x = I8051.int_size in Obj.magic (Joint.psd_argument_from_byte x)))), + (List.Cons ((Joint.OP2 (BackEndOps.Addc, (Obj.magic addr2), + (Obj.magic (Joint.psd_argument_from_reg addr2)), + (Obj.magic (Joint.psd_argument_from_byte Joint.zero_byte)))), + List.Nil))))) + +(** val set_params_stack : + AST.ident List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let set_params_stack globals params = + Bind_new.Bnew (fun addr1 -> Bind_new.Bnew (fun addr2 -> + let params_length_byte = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (List.length params) + in + let l = + List.append (List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD addr1); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW I8051.registerSPL)) })), + (List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD addr2); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW I8051.registerSPH)) })), + (List.Cons (Joint.CLEAR_CARRY, (List.Cons ((Joint.OP2 + (BackEndOps.Sub, (Obj.magic addr1), + (Obj.magic (Joint.psd_argument_from_reg addr1)), + (Obj.magic (Joint.psd_argument_from_byte params_length_byte)))), + (List.Cons ((Joint.OP2 (BackEndOps.Sub, (Obj.magic addr2), + (Obj.magic (Joint.psd_argument_from_reg addr2)), + (Obj.magic (Joint.psd_argument_from_byte Joint.zero_byte)))), + List.Nil)))))))))) + (List.flatten + (List.map (set_param_stack globals addr1 addr2) params)) + in + Bind_new.Bret l)) + +(** val set_params : + AST.ident List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + Types.sig0 **) +let set_params globals params = + let n = Nat.min (List.length params) (List.length I8051.registerParams) in + let hdw_stack_params = List.split params n in + let hdw_params = hdw_stack_params.Types.fst in + let stack_params = hdw_stack_params.Types.snd in + BindLists.bappend + (let l = set_params_hdw globals hdw_params in Bind_new.Bret l) + (set_params_stack globals stack_params) + +(** val fetch_result : + AST.ident List.list -> Registers.register List.list -> Joint.joint_seq + List.list Types.sig0 **) +let fetch_result globals ret_regs = + (let crl = Util.reduce_strong I8051.registerSTS I8051.registerRets in + (fun _ -> + let commonl = crl.Types.fst.Types.fst in + let commonr = crl.Types.snd.Types.fst in + List.append + (Util.map2 (fun st r -> Joint.MOVE + (Obj.magic { Types.fst = (ERTL.HDW st); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW r)) })) commonl commonr) + (let crl0 = Util.reduce_strong ret_regs I8051.registerSTS in + let commonl0 = crl0.Types.fst.Types.fst in + let commonr0 = crl0.Types.snd.Types.fst in + Util.map2 (fun ret st -> Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD ret); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW st)) })) commonl0 commonr0))) __ + +(** val translate_step : + AST.ident List.list -> Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block **) +let translate_step globals x = function +| Joint.COST_LABEL lbl -> + Bind_new.Bret { Types.fst = { Types.fst = List.Nil; Types.snd = (fun x0 -> + Joint.COST_LABEL lbl) }; Types.snd = List.Nil } +| Joint.CALL (f, args, ret_regs) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Bind_new.bindNew) + (Types.pi1 (Obj.magic (set_params globals (Obj.magic args)))) + (fun pref -> + Obj.magic (Bind_new.Bret { Types.fst = { Types.fst = + (Blocks.add_dummy_variance pref); Types.snd = (fun x0 -> Joint.CALL + (f, (Obj.magic (List.length (Obj.magic args))), + (Obj.magic Types.It))) }; Types.snd = + (Types.pi1 (fetch_result globals (Obj.magic ret_regs))) }))) +| Joint.COND (r, ltrue) -> + Bind_new.Bret { Types.fst = { Types.fst = List.Nil; Types.snd = (fun x0 -> + Joint.COND (r, ltrue)) }; Types.snd = List.Nil } +| Joint.Step_seq s0 -> + Bind_new.Bret + (match s0 with + | Joint.COMMENT msg -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.COMMENT msg), List.Nil)) + | Joint.MOVE rs -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD (Obj.magic rs).Types.fst); + Types.snd = + (ERTL.psd_argument_move_src (Obj.magic rs).Types.snd) })), + List.Nil)) + | Joint.POP x0 -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals List.Nil + | Joint.PUSH x0 -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals List.Nil + | Joint.ADDRESS (x0, off, r1, r2) -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.ADDRESS (x0, off, r1, r2)), List.Nil)) + | Joint.OPACCS (op, destr1, destr2, srcr1, srcr2) -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.OPACCS (op, destr1, destr2, srcr1, + srcr2)), List.Nil)) + | Joint.OP1 (op1, destr, srcr) -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.OP1 (op1, destr, srcr)), List.Nil)) + | Joint.OP2 (op2, destr, srcr1, srcr2) -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.OP2 (op2, destr, srcr1, srcr2)), + List.Nil)) + | Joint.CLEAR_CARRY -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons (Joint.CLEAR_CARRY, List.Nil)) + | Joint.SET_CARRY -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons (Joint.SET_CARRY, List.Nil)) + | Joint.LOAD (destr, addr1, addr2) -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.LOAD (destr, addr1, addr2)), List.Nil)) + | Joint.STORE (addr1, addr2, srcr) -> + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.STORE (addr1, addr2, srcr)), List.Nil)) + | Joint.Extension_seq ext -> + let RTL.Rtl_stack_address (addr1, addr2) = Obj.magic ext in + Blocks.ensure_step_block (Joint.graph_params_to_params ERTL.eRTL) + globals (List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD addr1); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW I8051.registerSPL)) })), + (List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = (ERTL.PSD addr2); Types.snd = + (ERTL.move_src_from_dst (ERTL.HDW I8051.registerSPH)) })), + List.Nil))))) + +(** val translate_fin_step : + AST.ident List.list -> Registers.register List.list -> Registers.register + -> Registers.register -> (Registers.register, I8051.register) Types.prod + List.list -> Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block **) +let translate_fin_step globals ret_regs ral rah to_restore x = function +| Joint.GOTO lbl' -> + Bind_new.Bret { Types.fst = List.Nil; Types.snd = (Joint.GOTO lbl') } +| Joint.RETURN -> + Bind_new.Bret { Types.fst = + (Types.pi1 (epilogue globals ret_regs ral rah to_restore)); Types.snd = + Joint.RETURN } +| Joint.TAILCALL (x0, x1) -> assert false (* absurd case *) + +(** val allocate_regs : + ((Registers.register, I8051.register) Types.prod List.list -> + (Registers.register, 'a1) Bind_new.bind_new) -> (Registers.register, 'a1) + Bind_new.bind_new **) +let allocate_regs f = + let allocate_regs_internal = fun acc r -> + Monad.m_bind0 (Monad.max_def Bind_new.bindNew) acc (fun tl -> + Obj.magic (Bind_new.Bnew (fun r' -> + Obj.magic + (Monad.m_return0 (Monad.max_def Bind_new.bindNew) (List.Cons + ({ Types.fst = r'; Types.snd = r }, tl)))))) + in + Obj.magic + (Monad.m_bind0 (Monad.max_def Bind_new.bindNew) + (Util.foldl allocate_regs_internal + (Monad.m_return0 (Monad.max_def Bind_new.bindNew) List.Nil) + I8051.registerCalleeSaved) (fun to_save -> Obj.magic f to_save)) + +(** val translate_data : + AST.ident List.list -> Joint.joint_closed_internal_function -> + TranslateUtils.bound_b_graph_translate_data **) +let translate_data globals def = + let params = (Types.pi1 def).Joint.joint_if_params in + let new_stacksize = + Nat.plus (Types.pi1 def).Joint.joint_if_stacksize + (Nat.minus (List.length (Obj.magic params)) + (List.length I8051.registerParams)) + in + allocate_regs (fun to_save -> Bind_new.Bnew (fun ral -> Bind_new.Bnew + (fun rah -> Bind_new.Bnew (fun tmpr -> Bind_new.Bnew (fun addr1 -> + Bind_new.Bnew (fun addr2 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Bind_new.bindNew) + (Obj.magic + (prologue globals (Obj.magic params) ral rah tmpr addr1 addr2 + to_save)) (fun prologue0 -> + Monad.m_return0 (Monad.max_def Bind_new.bindNew) + { TranslateUtils.init_ret = (Obj.magic Types.It); + TranslateUtils.init_params = + (Obj.magic (List.length (Obj.magic params))); + TranslateUtils.init_stack_size = new_stacksize; + TranslateUtils.added_prologue = prologue0; + TranslateUtils.new_regs = + (List.reverse (List.Cons (addr2, (List.Cons (addr1, (List.Cons + (tmpr, (List.Cons (rah, (List.Cons (ral, + (List.map (fun x -> x.Types.fst) to_save)))))))))))); + TranslateUtils.f_step = (translate_step globals); + TranslateUtils.f_fin = + (translate_fin_step globals + (Obj.magic (Types.pi1 def).Joint.joint_if_result) ral rah + to_save) })))))))) + +(** val rtl_to_ertl : RTL.rtl_program -> ERTL.ertl_program **) +let rtl_to_ertl = + TranslateUtils.b_graph_transform_program RTL.rTL ERTL.eRTL translate_data + diff --git a/extracted/rTLToERTL.mli b/extracted/rTLToERTL.mli new file mode 100644 index 0000000..a50e074 --- /dev/null +++ b/extracted/rTLToERTL.mli @@ -0,0 +1,222 @@ +open Preamble + +open Order + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Registers + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open BitVector + +open Arithmetic + +open Jmeq + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open I8051 + +open RegisterSet + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open CostLabel + +open Hide + +open Integers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open RTL + +open ERTL + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +val save_hdws : + AST.ident List.list -> (Registers.register, I8051.register) Types.prod + List.list -> Joint.joint_seq List.list + +val restore_hdws : + AST.ident List.list -> (Joint.psd_argument, I8051.register) Types.prod + List.list -> Joint.joint_seq List.list + +val get_params_hdw : + AST.ident List.list -> Registers.register List.list -> Joint.joint_seq + List.list + +val get_param_stack : + AST.ident List.list -> Registers.register -> Registers.register -> + Registers.register -> Joint.joint_seq List.list + +val get_params_stack : + AST.ident List.list -> Registers.register -> Registers.register -> + Registers.register -> Registers.register List.list -> Joint.joint_seq + List.list + +val get_params : + AST.ident List.list -> Registers.register -> Registers.register -> + Registers.register -> Registers.register List.list -> Joint.joint_seq + List.list + +val save_return : + AST.ident List.list -> Joint.psd_argument List.list -> Joint.joint_seq + List.list + +val assign_result : AST.ident List.list -> Joint.joint_seq List.list + +val epilogue : + AST.ident List.list -> Registers.register List.list -> Registers.register + -> Registers.register -> (Registers.register, I8051.register) Types.prod + List.list -> Joint.joint_seq List.list Types.sig0 + +val prologue : + AST.ident List.list -> Registers.register List.list -> Registers.register + -> Registers.register -> Registers.register -> Registers.register -> + Registers.register -> (Registers.register, I8051.register) Types.prod + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new + +val set_params_hdw : + AST.ident List.list -> Joint.psd_argument List.list -> Joint.joint_seq + List.list + +val set_param_stack : + AST.ident List.list -> Registers.register -> Registers.register -> + Joint.psd_argument -> Joint.joint_seq List.list + +val set_params_stack : + AST.ident List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new + +val set_params : + AST.ident List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new Types.sig0 + +val fetch_result : + AST.ident List.list -> Registers.register List.list -> Joint.joint_seq + List.list Types.sig0 + +val translate_step : + AST.ident List.list -> Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block + +val translate_fin_step : + AST.ident List.list -> Registers.register List.list -> Registers.register + -> Registers.register -> (Registers.register, I8051.register) Types.prod + List.list -> Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block + +val allocate_regs : + ((Registers.register, I8051.register) Types.prod List.list -> + (Registers.register, 'a1) Bind_new.bind_new) -> (Registers.register, 'a1) + Bind_new.bind_new + +val translate_data : + AST.ident List.list -> Joint.joint_closed_internal_function -> + TranslateUtils.bound_b_graph_translate_data + +val rtl_to_ertl : RTL.rtl_program -> ERTL.ertl_program + diff --git a/extracted/rTL_printer.ml b/extracted/rTL_printer.ml new file mode 100644 index 0000000..590e864 --- /dev/null +++ b/extracted/rTL_printer.ml @@ -0,0 +1,133 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open RTL + +(** val print_RTL_program : + 'a1 Joint_printer.printing_params -> RTL.rtl_program -> (AST.ident, 'a1 + List.list) Types.prod List.list **) +let print_RTL_program pp prog = + Joint_printer.print_joint_program (Joint.graph_params_to_params RTL.rTL) pp + prog + (Joint_printer.graph_code_iteration_params RTL.rTL + (Joint.prog_names (Joint.graph_params_to_params RTL.rTL) prog) pp) + diff --git a/extracted/rTL_printer.mli b/extracted/rTL_printer.mli new file mode 100644 index 0000000..89fc1c9 --- /dev/null +++ b/extracted/rTL_printer.mli @@ -0,0 +1,128 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open Joint_printer + +open RTL + +val print_RTL_program : + 'a1 Joint_printer.printing_params -> RTL.rtl_program -> (AST.ident, 'a1 + List.list) Types.prod List.list + diff --git a/extracted/rTL_semantics.ml b/extracted/rTL_semantics.ml new file mode 100644 index 0000000..e248552 --- /dev/null +++ b/extracted/rTL_semantics.ml @@ -0,0 +1,795 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open RTL + +type reg_sp = { reg_sp_env : ByteValues.beval Identifiers.identifier_map; + stackp : ByteValues.xpointer } + +(** val reg_sp_rect_Type4 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> + 'a1) -> reg_sp -> 'a1 **) +let rec reg_sp_rect_Type4 h_mk_reg_sp x_25168 = + let { reg_sp_env = reg_sp_env0; stackp = stackp0 } = x_25168 in + h_mk_reg_sp reg_sp_env0 stackp0 + +(** val reg_sp_rect_Type5 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> + 'a1) -> reg_sp -> 'a1 **) +let rec reg_sp_rect_Type5 h_mk_reg_sp x_25170 = + let { reg_sp_env = reg_sp_env0; stackp = stackp0 } = x_25170 in + h_mk_reg_sp reg_sp_env0 stackp0 + +(** val reg_sp_rect_Type3 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> + 'a1) -> reg_sp -> 'a1 **) +let rec reg_sp_rect_Type3 h_mk_reg_sp x_25172 = + let { reg_sp_env = reg_sp_env0; stackp = stackp0 } = x_25172 in + h_mk_reg_sp reg_sp_env0 stackp0 + +(** val reg_sp_rect_Type2 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> + 'a1) -> reg_sp -> 'a1 **) +let rec reg_sp_rect_Type2 h_mk_reg_sp x_25174 = + let { reg_sp_env = reg_sp_env0; stackp = stackp0 } = x_25174 in + h_mk_reg_sp reg_sp_env0 stackp0 + +(** val reg_sp_rect_Type1 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> + 'a1) -> reg_sp -> 'a1 **) +let rec reg_sp_rect_Type1 h_mk_reg_sp x_25176 = + let { reg_sp_env = reg_sp_env0; stackp = stackp0 } = x_25176 in + h_mk_reg_sp reg_sp_env0 stackp0 + +(** val reg_sp_rect_Type0 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> + 'a1) -> reg_sp -> 'a1 **) +let rec reg_sp_rect_Type0 h_mk_reg_sp x_25178 = + let { reg_sp_env = reg_sp_env0; stackp = stackp0 } = x_25178 in + h_mk_reg_sp reg_sp_env0 stackp0 + +(** val reg_sp_env : + reg_sp -> ByteValues.beval Identifiers.identifier_map **) +let rec reg_sp_env xxx = + xxx.reg_sp_env + +(** val stackp : reg_sp -> ByteValues.xpointer **) +let rec stackp xxx = + xxx.stackp + +(** val reg_sp_inv_rect_Type4 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 **) +let reg_sp_inv_rect_Type4 hterm h1 = + let hcut = reg_sp_rect_Type4 h1 hterm in hcut __ + +(** val reg_sp_inv_rect_Type3 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 **) +let reg_sp_inv_rect_Type3 hterm h1 = + let hcut = reg_sp_rect_Type3 h1 hterm in hcut __ + +(** val reg_sp_inv_rect_Type2 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 **) +let reg_sp_inv_rect_Type2 hterm h1 = + let hcut = reg_sp_rect_Type2 h1 hterm in hcut __ + +(** val reg_sp_inv_rect_Type1 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 **) +let reg_sp_inv_rect_Type1 hterm h1 = + let hcut = reg_sp_rect_Type1 h1 hterm in hcut __ + +(** val reg_sp_inv_rect_Type0 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 **) +let reg_sp_inv_rect_Type0 hterm h1 = + let hcut = reg_sp_rect_Type0 h1 hterm in hcut __ + +(** val reg_sp_discr : reg_sp -> reg_sp -> __ **) +let reg_sp_discr x y = + Logic.eq_rect_Type2 x + (let { reg_sp_env = a0; stackp = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val reg_sp_jmdiscr : reg_sp -> reg_sp -> __ **) +let reg_sp_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { reg_sp_env = a0; stackp = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val dpi1__o__reg_sp_env__o__inject : + (reg_sp, 'a1) Types.dPair -> ByteValues.beval Identifiers.identifier_map + Types.sig0 **) +let dpi1__o__reg_sp_env__o__inject x2 = + x2.Types.dpi1.reg_sp_env + +(** val eject__o__reg_sp_env__o__inject : + reg_sp Types.sig0 -> ByteValues.beval Identifiers.identifier_map + Types.sig0 **) +let eject__o__reg_sp_env__o__inject x2 = + (Types.pi1 x2).reg_sp_env + +(** val reg_sp_env__o__inject : + reg_sp -> ByteValues.beval Identifiers.identifier_map Types.sig0 **) +let reg_sp_env__o__inject x1 = + x1.reg_sp_env + +(** val dpi1__o__reg_sp_env : + (reg_sp, 'a1) Types.dPair -> ByteValues.beval Identifiers.identifier_map **) +let dpi1__o__reg_sp_env x1 = + x1.Types.dpi1.reg_sp_env + +(** val eject__o__reg_sp_env : + reg_sp Types.sig0 -> ByteValues.beval Identifiers.identifier_map **) +let eject__o__reg_sp_env x1 = + (Types.pi1 x1).reg_sp_env + +(** val reg_sp_store : + PreIdentifiers.identifier -> ByteValues.beval -> reg_sp -> reg_sp **) +let reg_sp_store reg v locals = + let locals' = SemanticsUtils.reg_store reg v locals.reg_sp_env in + { reg_sp_env = locals'; stackp = locals.stackp } + +(** val reg_sp_retrieve : + reg_sp -> Registers.register -> ByteValues.beval Errors.res **) +let reg_sp_retrieve locals = + SemanticsUtils.reg_retrieve locals.reg_sp_env + +(** val reg_sp_empty : ByteValues.xpointer -> reg_sp **) +let reg_sp_empty x = + { reg_sp_env = (Identifiers.empty_map PreIdentifiers.RegisterTag); stackp = + x } + +type frame = { fr_ret_regs : Registers.register List.list; + fr_pc : ByteValues.program_counter; + fr_carry : ByteValues.bebit; fr_regs : reg_sp } + +(** val frame_rect_Type4 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type4 h_mk_frame x_25194 = + let { fr_ret_regs = fr_ret_regs0; fr_pc = fr_pc0; fr_carry = fr_carry0; + fr_regs = fr_regs0 } = x_25194 + in + h_mk_frame fr_ret_regs0 fr_pc0 fr_carry0 fr_regs0 + +(** val frame_rect_Type5 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type5 h_mk_frame x_25196 = + let { fr_ret_regs = fr_ret_regs0; fr_pc = fr_pc0; fr_carry = fr_carry0; + fr_regs = fr_regs0 } = x_25196 + in + h_mk_frame fr_ret_regs0 fr_pc0 fr_carry0 fr_regs0 + +(** val frame_rect_Type3 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type3 h_mk_frame x_25198 = + let { fr_ret_regs = fr_ret_regs0; fr_pc = fr_pc0; fr_carry = fr_carry0; + fr_regs = fr_regs0 } = x_25198 + in + h_mk_frame fr_ret_regs0 fr_pc0 fr_carry0 fr_regs0 + +(** val frame_rect_Type2 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type2 h_mk_frame x_25200 = + let { fr_ret_regs = fr_ret_regs0; fr_pc = fr_pc0; fr_carry = fr_carry0; + fr_regs = fr_regs0 } = x_25200 + in + h_mk_frame fr_ret_regs0 fr_pc0 fr_carry0 fr_regs0 + +(** val frame_rect_Type1 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type1 h_mk_frame x_25202 = + let { fr_ret_regs = fr_ret_regs0; fr_pc = fr_pc0; fr_carry = fr_carry0; + fr_regs = fr_regs0 } = x_25202 + in + h_mk_frame fr_ret_regs0 fr_pc0 fr_carry0 fr_regs0 + +(** val frame_rect_Type0 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type0 h_mk_frame x_25204 = + let { fr_ret_regs = fr_ret_regs0; fr_pc = fr_pc0; fr_carry = fr_carry0; + fr_regs = fr_regs0 } = x_25204 + in + h_mk_frame fr_ret_regs0 fr_pc0 fr_carry0 fr_regs0 + +(** val fr_ret_regs : frame -> Registers.register List.list **) +let rec fr_ret_regs xxx = + xxx.fr_ret_regs + +(** val fr_pc : frame -> ByteValues.program_counter **) +let rec fr_pc xxx = + xxx.fr_pc + +(** val fr_carry : frame -> ByteValues.bebit **) +let rec fr_carry xxx = + xxx.fr_carry + +(** val fr_regs : frame -> reg_sp **) +let rec fr_regs xxx = + xxx.fr_regs + +(** val frame_inv_rect_Type4 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type4 hterm h1 = + let hcut = frame_rect_Type4 h1 hterm in hcut __ + +(** val frame_inv_rect_Type3 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type3 hterm h1 = + let hcut = frame_rect_Type3 h1 hterm in hcut __ + +(** val frame_inv_rect_Type2 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type2 hterm h1 = + let hcut = frame_rect_Type2 h1 hterm in hcut __ + +(** val frame_inv_rect_Type1 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type1 hterm h1 = + let hcut = frame_rect_Type1 h1 hterm in hcut __ + +(** val frame_inv_rect_Type0 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type0 hterm h1 = + let hcut = frame_rect_Type0 h1 hterm in hcut __ + +(** val frame_discr : frame -> frame -> __ **) +let frame_discr x y = + Logic.eq_rect_Type2 x + (let { fr_ret_regs = a0; fr_pc = a1; fr_carry = a2; fr_regs = a3 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val frame_jmdiscr : frame -> frame -> __ **) +let frame_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { fr_ret_regs = a0; fr_pc = a1; fr_carry = a2; fr_regs = a3 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val rTL_state_params : Joint_semantics.sem_state_params **) +let rTL_state_params = + { Joint_semantics.empty_framesT = (Obj.magic List.Nil); + Joint_semantics.empty_regsT = (Obj.magic reg_sp_empty); + Joint_semantics.load_sp = (fun env -> Errors.OK (Obj.magic env).stackp); + Joint_semantics.save_sp = (fun env -> + Obj.magic (fun x -> { reg_sp_env = (Obj.magic env).reg_sp_env; stackp = + x })) } + +type rTL_state = Joint_semantics.state + +(** val rtl_arg_retrieve : + reg_sp -> Joint.psd_argument -> ByteValues.beval Errors.res **) +let rtl_arg_retrieve env = function +| Joint.Reg r -> SemanticsUtils.reg_retrieve env.reg_sp_env r +| Joint.Imm b -> Errors.OK (ByteValues.BVByte b) + +(** val rtl_fetch_ra : + rTL_state -> (rTL_state, ByteValues.program_counter) Types.prod + Errors.res **) +let rtl_fetch_ra st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.FrameErrorOnPop), List.Nil)) + st.Joint_semantics.st_frms)) (fun frms -> + match frms with + | List.Nil -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.EmptyStack), List.Nil))) + | List.Cons (hd, tl) -> + Obj.magic (Errors.OK { Types.fst = st; Types.snd = hd.fr_pc }))) + +(** val rtl_init_local : Registers.register -> reg_sp -> reg_sp **) +let rtl_init_local local = + reg_sp_store local ByteValues.BVundef + +(** val rtl_setup_call_separate : + Nat.nat -> Registers.register List.list -> Joint.psd_argument List.list + -> rTL_state -> rTL_state Errors.res **) +let rtl_setup_call_separate stacksize formal_arg_regs actual_arg_regs st = + (let { Types.fst = mem; Types.snd = b } = + GenMem.alloc st.Joint_semantics.m (Z.z_of_nat Nat.O) + (Z.z_of_nat stacksize) + in + (fun _ -> + let sp = { Pointers.pblock = b; Pointers.poff = + (BitVector.zero Pointers.offset_size) } + in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.mfold_left2 (fun lenv dest src -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (rtl_arg_retrieve (Obj.magic st.Joint_semantics.regs) src)) + (fun v -> Obj.magic (Errors.OK (reg_sp_store dest v lenv))))) + (Errors.OK (reg_sp_empty sp)) formal_arg_regs actual_arg_regs)) + (fun new_regs -> + Obj.magic (Errors.OK + (Joint_semantics.set_regs rTL_state_params new_regs + (Joint_semantics.set_m rTL_state_params mem st))))))) __ + +(** val rtl_setup_call_separate_overflow : + Nat.nat -> Registers.register List.list -> Joint.psd_argument List.list + -> rTL_state -> rTL_state Errors.res **) +let rtl_setup_call_separate_overflow stacksize formal_arg_regs actual_arg_regs st = + match Nat.leb (Nat.S (Nat.plus stacksize st.Joint_semantics.stack_usage)) + (Exp.exp (Nat.S (Nat.S Nat.O)) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))))))))))) with + | Bool.True -> + rtl_setup_call_separate stacksize formal_arg_regs actual_arg_regs st + | Bool.False -> + Errors.Error (List.Cons ((Errors.MSG ErrorMessages.StackOverflow), + List.Nil)) + +(** val rtl_setup_call_unique : + Nat.nat -> Registers.register List.list -> Joint.psd_argument List.list + -> rTL_state -> rTL_state Errors.res **) +let rtl_setup_call_unique stacksize formal_arg_regs actual_arg_regs st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.sp rTL_state_params st)) (fun sp -> + let newsp = + Pointers.neg_shift_pointer (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Types.pi1 sp) + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) stacksize) + in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.mfold_left2 (fun lenv dest src -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (rtl_arg_retrieve (Obj.magic st.Joint_semantics.regs) src)) + (fun v -> Obj.magic (Errors.OK (reg_sp_store dest v lenv))))) + (Errors.OK (reg_sp_empty newsp)) formal_arg_regs actual_arg_regs)) + (fun new_regs -> + Obj.magic (Errors.OK + (Joint_semantics.set_regs rTL_state_params new_regs st))))) + +type rTL_state_pc = Joint_semantics.state_pc + +(** val rtl_save_frame : + Registers.register List.list -> rTL_state_pc -> __ **) +let rtl_save_frame retregs st = + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.FrameErrorOnPush), List.Nil)) + st.Joint_semantics.st_no_pc.Joint_semantics.st_frms)) (fun frms -> + let frame0 = List.Cons ({ fr_ret_regs = retregs; fr_pc = + st.Joint_semantics.pc; fr_carry = + st.Joint_semantics.st_no_pc.Joint_semantics.carry; fr_regs = + (Obj.magic st.Joint_semantics.st_no_pc.Joint_semantics.regs) }, frms) + in + Obj.magic (Errors.OK + (Joint_semantics.set_frms rTL_state_params (Obj.magic frame0) + st.Joint_semantics.st_no_pc))) + +(** val rtl_fetch_external_args : + AST.external_function -> rTL_state -> Joint.psd_argument List.list -> + Values.val0 List.list Errors.res **) +let rtl_fetch_external_args _ = + failwith "AXIOM TO BE REALIZED" + +(** val rtl_set_result : + Values.val0 List.list -> Registers.register List.list -> rTL_state -> + rTL_state Errors.res **) +let rtl_set_result _ = + failwith "AXIOM TO BE REALIZED" + +(** val rtl_reg_store : + PreIdentifiers.identifier -> ByteValues.beval -> Joint_semantics.state -> + Joint_semantics.state **) +let rtl_reg_store r v st = + let mem = reg_sp_store r v (Obj.magic st.Joint_semantics.regs) in + Joint_semantics.set_regs rTL_state_params (Obj.magic mem) st + +(** val rtl_reg_retrieve : + Joint_semantics.state -> Registers.register -> ByteValues.beval + Errors.res **) +let rtl_reg_retrieve st l = + reg_sp_retrieve (Obj.magic st.Joint_semantics.regs) l + +(** val rtl_read_result : + Registers.register List.list -> rTL_state -> ByteValues.beval List.list + Errors.res **) +let rtl_read_result rets st = + Obj.magic + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (rtl_reg_retrieve st)) rets) + +(** val rtl_pop_frame_separate : + Registers.register List.list -> rTL_state -> (rTL_state, + ByteValues.program_counter) Types.prod Errors.res **) +let rtl_pop_frame_separate ret st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.FrameErrorOnPop), List.Nil)) + st.Joint_semantics.st_frms)) (fun frms -> + match frms with + | List.Nil -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.EmptyStack), List.Nil))) + | List.Cons (hd, tl) -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (rtl_read_result ret st)) (fun ret_vals -> + let reg_vals = Util.zip_pottier hd.fr_ret_regs ret_vals in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.sp rTL_state_params st)) (fun sp -> + let st0 = + Joint_semantics.set_frms rTL_state_params (Obj.magic tl) + (Joint_semantics.set_regs rTL_state_params + (Obj.magic hd.fr_regs) + (Joint_semantics.set_carry rTL_state_params hd.fr_carry + (Joint_semantics.set_m rTL_state_params + (GenMem.free st.Joint_semantics.m + (Types.pi1 sp).Pointers.pblock) st))) + in + let pc = hd.fr_pc in + let st1 = + Util.foldl (fun st1 reg_val -> + rtl_reg_store reg_val.Types.fst reg_val.Types.snd st1) st0 + reg_vals + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = st1; + Types.snd = pc })))) + +(** val rtl_pop_frame_unique : + Registers.register List.list -> rTL_state -> (rTL_state, + ByteValues.program_counter) Types.prod Errors.res **) +let rtl_pop_frame_unique ret st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.FrameErrorOnPop), List.Nil)) + st.Joint_semantics.st_frms)) (fun frms -> + match frms with + | List.Nil -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.EmptyStack), List.Nil))) + | List.Cons (hd, tl) -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (rtl_read_result ret st)) (fun ret_vals -> + let reg_vals = Util.zip_pottier hd.fr_ret_regs ret_vals in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.sp rTL_state_params st)) (fun sp -> + let st0 = + Joint_semantics.set_frms rTL_state_params (Obj.magic tl) + (Joint_semantics.set_regs rTL_state_params + (Obj.magic hd.fr_regs) + (Joint_semantics.set_carry rTL_state_params hd.fr_carry st)) + in + let pc = hd.fr_pc in + let st1 = + Util.foldl (fun st1 reg_val -> + rtl_reg_store reg_val.Types.fst reg_val.Types.snd st1) st0 + reg_vals + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = st1; + Types.snd = pc })))) + +(** val block_of_register_pair : + Registers.register -> Registers.register -> rTL_state -> Pointers.block + Errors.res **) +let block_of_register_pair r1 r2 st = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (rtl_reg_retrieve st r1)) (fun v1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (rtl_reg_retrieve st r2)) (fun v2 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (BEMem.pointer_of_address { Types.fst = v1; Types.snd = v2 })) + (fun ptr -> Obj.magic (Errors.OK ptr.Pointers.pblock))))) + +(** val eval_rtl_seq : + RTL.rtl_seq -> AST.ident -> rTL_state -> rTL_state Errors.res **) +let eval_rtl_seq stm curr_fn st = + let RTL.Rtl_stack_address (dreg1, dreg2) = stm in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Joint_semantics.sp rTL_state_params st)) (fun sp -> + let { Types.fst = dpl; Types.snd = dph } = + ByteValues.beval_pair_of_pointer (Types.pi1 sp) + in + let st0 = rtl_reg_store dreg1 dpl st in + Monad.m_return0 (Monad.max_def Errors.res0) + (rtl_reg_store dreg2 dph st0))) + +(** val reg_res_store : + PreIdentifiers.identifier -> ByteValues.beval -> reg_sp -> reg_sp + Errors.res **) +let reg_res_store r v s = + Errors.OK (reg_sp_store r v s) + +(** val rTL_semantics_separate : SemanticsUtils.sem_graph_params **) +let rTL_semantics_separate = + { SemanticsUtils.sgp_pars = + (Joint.gp_to_p__o__stmt_pars__o__uns_pars RTL.rTL); + SemanticsUtils.sgp_sup = (fun _ -> { Joint_semantics.st_pars = + rTL_state_params; Joint_semantics.acca_store_ = + (Obj.magic reg_res_store); Joint_semantics.acca_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.acca_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.accb_store_ = + (Obj.magic reg_res_store); Joint_semantics.accb_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.accb_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.dpl_store_ = + (Obj.magic reg_res_store); Joint_semantics.dpl_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.dpl_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.dph_store_ = + (Obj.magic reg_res_store); Joint_semantics.dph_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.dph_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.snd_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.pair_reg_move_ = + (fun env p -> + let { Types.fst = dest; Types.snd = src } = Obj.magic p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (rtl_arg_retrieve (Obj.magic env) src)) (fun v -> + Monad.m_return0 (Monad.max_def Errors.res0) + (reg_sp_store dest v (Obj.magic env))))); + Joint_semantics.save_frame = (fun x -> Obj.magic rtl_save_frame); + Joint_semantics.setup_call = (Obj.magic rtl_setup_call_separate); + Joint_semantics.fetch_external_args = + (Obj.magic rtl_fetch_external_args); Joint_semantics.set_result = + (Obj.magic rtl_set_result); Joint_semantics.call_args_for_main = + (Obj.magic List.Nil); Joint_semantics.call_dest_for_main = + (Obj.magic (List.Cons (Positive.One, (List.Cons ((Positive.P0 + Positive.One), (List.Cons ((Positive.P1 Positive.One), (List.Cons + ((Positive.P0 (Positive.P0 Positive.One)), List.Nil))))))))); + Joint_semantics.read_result = (fun x x0 -> Obj.magic rtl_read_result); + Joint_semantics.eval_ext_seq = (fun x x0 -> Obj.magic eval_rtl_seq); + Joint_semantics.pop_frame = (fun x x0 x1 -> + Obj.magic rtl_pop_frame_separate) }); + SemanticsUtils.graph_pre_main_generator = RTL.rTL_premain } + +(** val rTL_semantics_separate_overflow : SemanticsUtils.sem_graph_params **) +let rTL_semantics_separate_overflow = + { SemanticsUtils.sgp_pars = + (Joint.gp_to_p__o__stmt_pars__o__uns_pars RTL.rTL); + SemanticsUtils.sgp_sup = (fun _ -> { Joint_semantics.st_pars = + rTL_state_params; Joint_semantics.acca_store_ = + (Obj.magic reg_res_store); Joint_semantics.acca_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.acca_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.accb_store_ = + (Obj.magic reg_res_store); Joint_semantics.accb_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.accb_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.dpl_store_ = + (Obj.magic reg_res_store); Joint_semantics.dpl_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.dpl_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.dph_store_ = + (Obj.magic reg_res_store); Joint_semantics.dph_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.dph_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.snd_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.pair_reg_move_ = + (fun env p -> + let { Types.fst = dest; Types.snd = src } = Obj.magic p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (rtl_arg_retrieve (Obj.magic env) src)) (fun v -> + Monad.m_return0 (Monad.max_def Errors.res0) + (reg_sp_store dest v (Obj.magic env))))); + Joint_semantics.save_frame = (fun x -> Obj.magic rtl_save_frame); + Joint_semantics.setup_call = + (Obj.magic rtl_setup_call_separate_overflow); + Joint_semantics.fetch_external_args = + (Obj.magic rtl_fetch_external_args); Joint_semantics.set_result = + (Obj.magic rtl_set_result); Joint_semantics.call_args_for_main = + (Obj.magic List.Nil); Joint_semantics.call_dest_for_main = + (Obj.magic (List.Cons (Positive.One, (List.Cons ((Positive.P0 + Positive.One), (List.Cons ((Positive.P1 Positive.One), (List.Cons + ((Positive.P0 (Positive.P0 Positive.One)), List.Nil))))))))); + Joint_semantics.read_result = (fun x x0 -> Obj.magic rtl_read_result); + Joint_semantics.eval_ext_seq = (fun x x0 -> Obj.magic eval_rtl_seq); + Joint_semantics.pop_frame = (fun x x0 x1 -> + Obj.magic rtl_pop_frame_separate) }); + SemanticsUtils.graph_pre_main_generator = RTL.rTL_premain } + +(** val rTL_semantics_unique : SemanticsUtils.sem_graph_params **) +let rTL_semantics_unique = + { SemanticsUtils.sgp_pars = + (Joint.gp_to_p__o__stmt_pars__o__uns_pars RTL.rTL); + SemanticsUtils.sgp_sup = (fun _ -> { Joint_semantics.st_pars = + rTL_state_params; Joint_semantics.acca_store_ = + (Obj.magic reg_res_store); Joint_semantics.acca_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.acca_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.accb_store_ = + (Obj.magic reg_res_store); Joint_semantics.accb_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.accb_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.dpl_store_ = + (Obj.magic reg_res_store); Joint_semantics.dpl_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.dpl_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.dph_store_ = + (Obj.magic reg_res_store); Joint_semantics.dph_retrieve_ = + (Obj.magic reg_sp_retrieve); Joint_semantics.dph_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.snd_arg_retrieve_ = + (Obj.magic rtl_arg_retrieve); Joint_semantics.pair_reg_move_ = + (fun env p -> + let { Types.fst = dest; Types.snd = src } = Obj.magic p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (rtl_arg_retrieve (Obj.magic env) src)) (fun v -> + Monad.m_return0 (Monad.max_def Errors.res0) + (reg_sp_store dest v (Obj.magic env))))); + Joint_semantics.save_frame = (fun x -> Obj.magic rtl_save_frame); + Joint_semantics.setup_call = (Obj.magic rtl_setup_call_unique); + Joint_semantics.fetch_external_args = + (Obj.magic rtl_fetch_external_args); Joint_semantics.set_result = + (Obj.magic rtl_set_result); Joint_semantics.call_args_for_main = + (Obj.magic List.Nil); Joint_semantics.call_dest_for_main = + (Obj.magic (List.Cons (Positive.One, (List.Cons ((Positive.P0 + Positive.One), (List.Cons ((Positive.P1 Positive.One), (List.Cons + ((Positive.P0 (Positive.P0 Positive.One)), List.Nil))))))))); + Joint_semantics.read_result = (fun x x0 -> Obj.magic rtl_read_result); + Joint_semantics.eval_ext_seq = (fun x x0 -> Obj.magic eval_rtl_seq); + Joint_semantics.pop_frame = (fun x x0 x1 -> + Obj.magic rtl_pop_frame_unique) }); + SemanticsUtils.graph_pre_main_generator = RTL.rTL_premain } + diff --git a/extracted/rTL_semantics.mli b/extracted/rTL_semantics.mli new file mode 100644 index 0000000..ff2d7d0 --- /dev/null +++ b/extracted/rTL_semantics.mli @@ -0,0 +1,363 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open RTL + +type reg_sp = { reg_sp_env : ByteValues.beval Identifiers.identifier_map; + stackp : ByteValues.xpointer } + +val reg_sp_rect_Type4 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> 'a1) + -> reg_sp -> 'a1 + +val reg_sp_rect_Type5 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> 'a1) + -> reg_sp -> 'a1 + +val reg_sp_rect_Type3 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> 'a1) + -> reg_sp -> 'a1 + +val reg_sp_rect_Type2 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> 'a1) + -> reg_sp -> 'a1 + +val reg_sp_rect_Type1 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> 'a1) + -> reg_sp -> 'a1 + +val reg_sp_rect_Type0 : + (ByteValues.beval Identifiers.identifier_map -> ByteValues.xpointer -> 'a1) + -> reg_sp -> 'a1 + +val reg_sp_env : reg_sp -> ByteValues.beval Identifiers.identifier_map + +val stackp : reg_sp -> ByteValues.xpointer + +val reg_sp_inv_rect_Type4 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 + +val reg_sp_inv_rect_Type3 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 + +val reg_sp_inv_rect_Type2 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 + +val reg_sp_inv_rect_Type1 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 + +val reg_sp_inv_rect_Type0 : + reg_sp -> (ByteValues.beval Identifiers.identifier_map -> + ByteValues.xpointer -> __ -> 'a1) -> 'a1 + +val reg_sp_discr : reg_sp -> reg_sp -> __ + +val reg_sp_jmdiscr : reg_sp -> reg_sp -> __ + +val dpi1__o__reg_sp_env__o__inject : + (reg_sp, 'a1) Types.dPair -> ByteValues.beval Identifiers.identifier_map + Types.sig0 + +val eject__o__reg_sp_env__o__inject : + reg_sp Types.sig0 -> ByteValues.beval Identifiers.identifier_map Types.sig0 + +val reg_sp_env__o__inject : + reg_sp -> ByteValues.beval Identifiers.identifier_map Types.sig0 + +val dpi1__o__reg_sp_env : + (reg_sp, 'a1) Types.dPair -> ByteValues.beval Identifiers.identifier_map + +val eject__o__reg_sp_env : + reg_sp Types.sig0 -> ByteValues.beval Identifiers.identifier_map + +val reg_sp_store : + PreIdentifiers.identifier -> ByteValues.beval -> reg_sp -> reg_sp + +val reg_sp_retrieve : + reg_sp -> Registers.register -> ByteValues.beval Errors.res + +val reg_sp_empty : ByteValues.xpointer -> reg_sp + +type frame = { fr_ret_regs : Registers.register List.list; + fr_pc : ByteValues.program_counter; + fr_carry : ByteValues.bebit; fr_regs : reg_sp } + +val frame_rect_Type4 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 + +val frame_rect_Type5 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 + +val frame_rect_Type3 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 + +val frame_rect_Type2 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 + +val frame_rect_Type1 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 + +val frame_rect_Type0 : + (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> 'a1) -> frame -> 'a1 + +val fr_ret_regs : frame -> Registers.register List.list + +val fr_pc : frame -> ByteValues.program_counter + +val fr_carry : frame -> ByteValues.bebit + +val fr_regs : frame -> reg_sp + +val frame_inv_rect_Type4 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type3 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type2 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type1 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type0 : + frame -> (Registers.register List.list -> ByteValues.program_counter -> + ByteValues.bebit -> reg_sp -> __ -> 'a1) -> 'a1 + +val frame_discr : frame -> frame -> __ + +val frame_jmdiscr : frame -> frame -> __ + +val rTL_state_params : Joint_semantics.sem_state_params + +type rTL_state = Joint_semantics.state + +val rtl_arg_retrieve : + reg_sp -> Joint.psd_argument -> ByteValues.beval Errors.res + +val rtl_fetch_ra : + rTL_state -> (rTL_state, ByteValues.program_counter) Types.prod Errors.res + +val rtl_init_local : Registers.register -> reg_sp -> reg_sp + +val rtl_setup_call_separate : + Nat.nat -> Registers.register List.list -> Joint.psd_argument List.list -> + rTL_state -> rTL_state Errors.res + +val rtl_setup_call_separate_overflow : + Nat.nat -> Registers.register List.list -> Joint.psd_argument List.list -> + rTL_state -> rTL_state Errors.res + +val rtl_setup_call_unique : + Nat.nat -> Registers.register List.list -> Joint.psd_argument List.list -> + rTL_state -> rTL_state Errors.res + +type rTL_state_pc = Joint_semantics.state_pc + +val rtl_save_frame : Registers.register List.list -> rTL_state_pc -> __ + +val rtl_fetch_external_args : + AST.external_function -> rTL_state -> Joint.psd_argument List.list -> + Values.val0 List.list Errors.res + +val rtl_set_result : + Values.val0 List.list -> Registers.register List.list -> rTL_state -> + rTL_state Errors.res + +val rtl_reg_store : + PreIdentifiers.identifier -> ByteValues.beval -> Joint_semantics.state -> + Joint_semantics.state + +val rtl_reg_retrieve : + Joint_semantics.state -> Registers.register -> ByteValues.beval Errors.res + +val rtl_read_result : + Registers.register List.list -> rTL_state -> ByteValues.beval List.list + Errors.res + +val rtl_pop_frame_separate : + Registers.register List.list -> rTL_state -> (rTL_state, + ByteValues.program_counter) Types.prod Errors.res + +val rtl_pop_frame_unique : + Registers.register List.list -> rTL_state -> (rTL_state, + ByteValues.program_counter) Types.prod Errors.res + +val block_of_register_pair : + Registers.register -> Registers.register -> rTL_state -> Pointers.block + Errors.res + +val eval_rtl_seq : + RTL.rtl_seq -> AST.ident -> rTL_state -> rTL_state Errors.res + +val reg_res_store : + PreIdentifiers.identifier -> ByteValues.beval -> reg_sp -> reg_sp + Errors.res + +val rTL_semantics_separate : SemanticsUtils.sem_graph_params + +val rTL_semantics_separate_overflow : SemanticsUtils.sem_graph_params + +val rTL_semantics_unique : SemanticsUtils.sem_graph_params + diff --git a/extracted/rTLabsToRTL.ml b/extracted/rTLabsToRTL.ml new file mode 100644 index 0000000..c7332e8 --- /dev/null +++ b/extracted/rTLabsToRTL.ml @@ -0,0 +1,1283 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open Extra_bool + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open I8051 + +open BackEndOps + +open Joint + +open RTL + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +(** val size_of_sig_type : AST.typ -> Nat.nat **) +let size_of_sig_type = function +| AST.ASTint (isize, sign) -> + (match isize with + | AST.I8 -> Nat.S Nat.O + | AST.I16 -> Nat.S (Nat.S Nat.O) + | AST.I32 -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) +| AST.ASTptr -> Nat.S (Nat.S Nat.O) + +(** val sign_of_sig_type : AST.typ -> AST.signedness **) +let sign_of_sig_type = function +| AST.ASTint (x, sign) -> sign +| AST.ASTptr -> AST.Unsigned + +type register_type = +| Register_int of Registers.register +| Register_ptr of Registers.register * Registers.register + +(** val register_type_rect_Type4 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register + -> 'a1) -> register_type -> 'a1 **) +let rec register_type_rect_Type4 h_register_int h_register_ptr = function +| Register_int x_18380 -> h_register_int x_18380 +| Register_ptr (x_18382, x_18381) -> h_register_ptr x_18382 x_18381 + +(** val register_type_rect_Type5 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register + -> 'a1) -> register_type -> 'a1 **) +let rec register_type_rect_Type5 h_register_int h_register_ptr = function +| Register_int x_18386 -> h_register_int x_18386 +| Register_ptr (x_18388, x_18387) -> h_register_ptr x_18388 x_18387 + +(** val register_type_rect_Type3 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register + -> 'a1) -> register_type -> 'a1 **) +let rec register_type_rect_Type3 h_register_int h_register_ptr = function +| Register_int x_18392 -> h_register_int x_18392 +| Register_ptr (x_18394, x_18393) -> h_register_ptr x_18394 x_18393 + +(** val register_type_rect_Type2 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register + -> 'a1) -> register_type -> 'a1 **) +let rec register_type_rect_Type2 h_register_int h_register_ptr = function +| Register_int x_18398 -> h_register_int x_18398 +| Register_ptr (x_18400, x_18399) -> h_register_ptr x_18400 x_18399 + +(** val register_type_rect_Type1 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register + -> 'a1) -> register_type -> 'a1 **) +let rec register_type_rect_Type1 h_register_int h_register_ptr = function +| Register_int x_18404 -> h_register_int x_18404 +| Register_ptr (x_18406, x_18405) -> h_register_ptr x_18406 x_18405 + +(** val register_type_rect_Type0 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register + -> 'a1) -> register_type -> 'a1 **) +let rec register_type_rect_Type0 h_register_int h_register_ptr = function +| Register_int x_18410 -> h_register_int x_18410 +| Register_ptr (x_18412, x_18411) -> h_register_ptr x_18412 x_18411 + +(** val register_type_inv_rect_Type4 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 **) +let register_type_inv_rect_Type4 hterm h1 h2 = + let hcut = register_type_rect_Type4 h1 h2 hterm in hcut __ + +(** val register_type_inv_rect_Type3 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 **) +let register_type_inv_rect_Type3 hterm h1 h2 = + let hcut = register_type_rect_Type3 h1 h2 hterm in hcut __ + +(** val register_type_inv_rect_Type2 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 **) +let register_type_inv_rect_Type2 hterm h1 h2 = + let hcut = register_type_rect_Type2 h1 h2 hterm in hcut __ + +(** val register_type_inv_rect_Type1 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 **) +let register_type_inv_rect_Type1 hterm h1 h2 = + let hcut = register_type_rect_Type1 h1 h2 hterm in hcut __ + +(** val register_type_inv_rect_Type0 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 **) +let register_type_inv_rect_Type0 hterm h1 h2 = + let hcut = register_type_rect_Type0 h1 h2 hterm in hcut __ + +(** val register_type_discr : register_type -> register_type -> __ **) +let register_type_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Register_int a0 -> Obj.magic (fun _ dH -> dH __) + | Register_ptr (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val register_type_jmdiscr : register_type -> register_type -> __ **) +let register_type_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Register_int a0 -> Obj.magic (fun _ dH -> dH __) + | Register_ptr (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +type local_env = Registers.register List.list Identifiers.identifier_map + +(** val find_local_env : + PreIdentifiers.identifier -> local_env -> Registers.register List.list **) +let find_local_env r lenv = + Option.opt_safe (Identifiers.lookup PreIdentifiers.RegisterTag lenv r) + +(** val find_local_env_arg : + Registers.register -> local_env -> Joint.psd_argument List.list **) +let find_local_env_arg r lenv = + List.map (fun x -> Joint.Reg x) (find_local_env r lenv) + +(** val m_iter : Monad.monad -> ('a1 -> __) -> Nat.nat -> __ -> __ **) +let rec m_iter m f n m0 = + match n with + | Nat.O -> m0 + | Nat.S k -> Monad.m_bind0 m m0 (fun v -> m_iter m f k (f v)) + +(** val fresh_registers : + Joint.params -> AST.ident List.list -> Nat.nat -> Registers.register + List.list Monad.smax_def__o__monad **) +let fresh_registers p g n = + let f = fun acc -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (TranslateUtils.fresh_register p g) (fun m -> + Monad.m_return0 (Monad.smax_def State.state_monad) (List.Cons (m, acc))) + in + m_iter (Monad.smax_def State.state_monad) f n + (Monad.m_return0 (Monad.smax_def State.state_monad) List.Nil) + +(** val map_list_local_env : + Registers.register List.list Identifiers.identifier_map -> + (Registers.register, AST.typ) Types.prod List.list -> Registers.register + List.list **) +let rec map_list_local_env lenv regs = + (match regs with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (hd, tl) -> + (fun _ -> + List.append (find_local_env hd.Types.fst lenv) + (map_list_local_env lenv tl))) __ + +(** val initialize_local_env : + AST.ident List.list -> (Registers.register, AST.typ) Types.prod List.list + -> local_env Monad.smax_def__o__monad **) +let initialize_local_env globals registers = + let f = fun r_sig lenv -> + let { Types.fst = r; Types.snd = sig0 } = r_sig in + let size = size_of_sig_type sig0 in + Monad.m_bind0 (Monad.smax_def State.state_monad) + (fresh_registers (Joint.graph_params_to_params RTL.rTL) globals size) + (fun regs -> + Monad.m_return0 (Monad.smax_def State.state_monad) + (Identifiers.add PreIdentifiers.RegisterTag lenv r regs)) + in + Monad.m_fold (Monad.smax_def State.state_monad) f registers + (Identifiers.empty_map PreIdentifiers.RegisterTag) + +(** val initialize_locals_params_ret : + AST.ident List.list -> (Registers.register, AST.typ) Types.prod List.list + -> (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod Types.option -> local_env + Monad.smax_def__o__monad **) +let initialize_locals_params_ret globals locals params ret = + Obj.magic (fun def -> + (let { Types.fst = def'; Types.snd = lenv } = + Obj.magic initialize_local_env globals + (List.append + (match ret with + | Types.None -> List.Nil + | Types.Some r_sig -> List.Cons (r_sig, List.Nil)) + (List.append locals params)) def + in + (fun _ -> + let params' = map_list_local_env lenv params in + let ret' = + (match ret with + | Types.None -> (fun _ -> List.Nil) + | Types.Some r_sig -> (fun _ -> find_local_env r_sig.Types.fst lenv)) + __ + in + let def'' = { Joint.joint_if_luniverse = def'.Joint.joint_if_luniverse; + Joint.joint_if_runiverse = def'.Joint.joint_if_runiverse; + Joint.joint_if_result = (Obj.magic ret'); Joint.joint_if_params = + (Obj.magic params'); Joint.joint_if_stacksize = + def'.Joint.joint_if_stacksize; Joint.joint_if_local_stacksize = + def'.Joint.joint_if_local_stacksize; Joint.joint_if_code = + def'.Joint.joint_if_code; Joint.joint_if_entry = + def'.Joint.joint_if_entry } + in + { Types.fst = def''; Types.snd = lenv })) __) + +(** val make_addr : 'a1 List.list -> ('a1, 'a1) Types.prod **) +let make_addr lst = + { Types.fst = (Util.nth_safe Nat.O lst); Types.snd = + (Util.nth_safe (Nat.S Nat.O) lst) } + +(** val find_and_addr : + PreIdentifiers.identifier -> local_env -> (Registers.register, + Registers.register) Types.prod **) +let find_and_addr r lenv = + make_addr (find_local_env r lenv) + +(** val find_and_addr_arg : + Registers.register -> local_env -> (Joint.psd_argument, + Joint.psd_argument) Types.prod **) +let find_and_addr_arg r lenv = + make_addr (find_local_env_arg r lenv) + +(** val rtl_args : + Registers.register List.list -> local_env -> Joint.psd_argument List.list **) +let rec rtl_args args env = + (match args with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (hd, tl) -> + (fun _ -> List.append (find_local_env_arg hd env) (rtl_args tl env))) __ + +(** val vrsplit : + Nat.nat -> Nat.nat -> 'a1 Vector.vector -> 'a1 Vector.vector List.list + Types.sig0 **) +let rec vrsplit m n = + match m with + | Nat.O -> (fun v -> List.Nil) + | Nat.S k -> + (fun v -> + let spl = Vector.vsplit n (Nat.times k n) v in + List.Cons (spl.Types.fst, (Types.pi1 (vrsplit k n spl.Types.snd)))) + +(** val split_into_bytes : + AST.intsize -> AST.bvint -> BitVector.byte List.list Types.sig0 **) +let split_into_bytes size int = + List.reverse + (Types.pi1 + (vrsplit (AST.size_intsize size) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))) int)) + +(** val list_inject_All_aux : 'a1 List.list -> 'a1 Types.sig0 List.list **) +let rec list_inject_All_aux l = + (match l with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (hd, tl) -> + (fun _ -> List.Cons (hd, (list_inject_All_aux tl)))) __ + +(** val translate_op_aux : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + Joint.joint_seq List.list **) +let translate_op_aux globals op destrs srcrs1 srcrs2 = + Util.map3 (fun x x0 x1 -> Joint.OP2 (op, x, x0, x1)) (Obj.magic destrs) + (Obj.magic srcrs1) (Obj.magic srcrs2) + +(** val translate_op : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + Joint.joint_seq List.list **) +let translate_op globals op destrs srcrs1 srcrs2 = + (match op with + | BackEndOps.Add -> + (match destrs with + | List.Nil -> (fun _ _ -> List.Nil) + | List.Cons (destr, destrs') -> + (match srcrs1 with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (srcr1, srcrs1') -> + (fun _ -> + match srcrs2 with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (srcr2, srcrs2') -> + (fun _ -> List.Cons ((Joint.OP2 (BackEndOps.Add, + (Obj.magic destr), (Obj.magic srcr1), (Obj.magic srcr2))), + (translate_op_aux globals BackEndOps.Addc destrs' srcrs1' + srcrs2')))))) + | BackEndOps.Addc -> + (fun _ _ -> + List.append (List.Cons (Joint.CLEAR_CARRY, List.Nil)) + (translate_op_aux globals BackEndOps.Addc destrs srcrs1 srcrs2)) + | BackEndOps.Sub -> + (fun _ _ -> + List.append (List.Cons (Joint.CLEAR_CARRY, List.Nil)) + (translate_op_aux globals BackEndOps.Sub destrs srcrs1 srcrs2)) + | BackEndOps.And -> + (fun _ _ -> translate_op_aux globals op destrs srcrs1 srcrs2) + | BackEndOps.Or -> + (fun _ _ -> translate_op_aux globals op destrs srcrs1 srcrs2) + | BackEndOps.Xor -> + (fun _ _ -> translate_op_aux globals op destrs srcrs1 srcrs2)) __ __ + +(** val cast_list : 'a1 -> Nat.nat -> 'a1 List.list -> 'a1 List.list **) +let cast_list deflt new_length l = + match Nat.leb (List.length l) new_length with + | Bool.True -> + List.append l + (List.make_list deflt (Nat.minus new_length (List.length l))) + | Bool.False -> List.lhd l new_length + +(** val translate_op_asym_unsigned : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + Joint.joint_seq List.list **) +let translate_op_asym_unsigned globals op destrs srcrs1 srcrs2 = + let l = List.length destrs in + let srcrs1' = + cast_list (let x = Joint.psd_argument_from_byte Joint.zero_byte in x) l + srcrs1 + in + let srcrs2' = + cast_list (let x = Joint.psd_argument_from_byte Joint.zero_byte in x) l + srcrs2 + in + translate_op globals op destrs srcrs1' srcrs2' + +(** val zero_args : Nat.nat -> Joint.psd_argument List.list Types.sig0 **) +let zero_args size = + List.make_list (Joint.psd_argument_from_byte Joint.zero_byte) size + +(** val one_args : Nat.nat -> Joint.psd_argument List.list Types.sig0 **) +let one_args = function +| Nat.O -> List.Nil +| Nat.S k -> + List.Cons + ((let x = Joint.psd_argument_from_byte (Joint.byte_of_nat (Nat.S Nat.O)) + in + x), (Types.pi1 (zero_args k))) + +(** val size_of_cst : AST.typ -> FrontEndOps.constant -> Nat.nat **) +let size_of_cst typ = function +| FrontEndOps.Ointconst (size, x, x0) -> AST.size_intsize size +| FrontEndOps.Oaddrsymbol (x, x0) -> Nat.S (Nat.S Nat.O) +| FrontEndOps.Oaddrstack x -> Nat.S (Nat.S Nat.O) + +(** val translate_cst : + AST.typ -> AST.ident List.list -> FrontEndOps.constant Types.sig0 -> + Registers.register List.list -> (Registers.register, Joint.joint_seq + List.list) Bind_new.bind_new **) +let translate_cst ty globals cst_sig destrs = + let l = + (match Types.pi1 cst_sig with + | FrontEndOps.Ointconst (size, sign, const) -> + (fun _ _ -> + Util.map2 (fun r b -> Joint.MOVE + (Obj.magic { Types.fst = r; Types.snd = + (Joint.psd_argument_from_byte b) })) destrs + (Types.pi1 (split_into_bytes size const))) + | FrontEndOps.Oaddrsymbol (id, offset) -> + (fun _ _ -> + let { Types.fst = r1; Types.snd = r2 } = make_addr destrs in + let off = + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))))))) offset + in + List.Cons ((Joint.ADDRESS (id, off, (Obj.magic r1), + (Obj.magic r2))), List.Nil)) + | FrontEndOps.Oaddrstack offset -> + (fun _ _ -> + let { Types.fst = r1; Types.snd = r2 } = make_addr destrs in + List.Cons + ((let x = Joint.Extension_seq + (Obj.magic (RTL.Rtl_stack_address (r1, r2))) + in + x), + (match Nat.eqb offset Nat.O with + | Bool.True -> List.Nil + | Bool.False -> + translate_op globals BackEndOps.Add (List.Cons (r1, (List.Cons + (r2, List.Nil)))) (List.Cons ((Joint.psd_argument_from_reg r1), + (List.Cons ((Joint.psd_argument_from_reg r2), List.Nil)))) + (List.Cons + ((Joint.psd_argument_from_byte (Joint.byte_of_nat offset)), + (List.Cons ((Joint.psd_argument_from_byte Joint.zero_byte), + List.Nil)))))))) __ __ + in + Bind_new.Bret l + +(** val translate_move : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.joint_seq List.list **) +let translate_move globals destrs srcrs = + Util.map2 (fun dst src -> Joint.MOVE + (Obj.magic { Types.fst = dst; Types.snd = src })) destrs srcrs + +(** val sign_mask : + AST.ident List.list -> Registers.register -> Joint.psd_argument -> + Joint.joint_seq List.list **) +let sign_mask globals destr = function +| Joint.Reg srcr -> + let byte_127 = Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), Bool.False, + (BitVector.maximum (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) + in + List.Cons ((Joint.OP2 (BackEndOps.Or, (Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_reg srcr)), + (Obj.magic (Joint.psd_argument_from_byte byte_127)))), (List.Cons + ((Joint.OP1 (BackEndOps.Rl, (Obj.magic destr), (Obj.magic destr))), + (List.Cons ((Joint.OP1 (BackEndOps.Inc, (Obj.magic destr), + (Obj.magic destr))), (List.Cons ((Joint.OP1 (BackEndOps.Cmpl, + (Obj.magic destr), (Obj.magic destr))), List.Nil))))))) +| Joint.Imm b -> + (match Arithmetic.sign_bit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) b with + | Bool.True -> + List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = destr; Types.snd = + (let x = + BitVector.maximum (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + in + Joint.psd_argument_from_byte x) })), List.Nil) + | Bool.False -> + List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = destr; Types.snd = + (Joint.psd_argument_from_byte Joint.zero_byte) })), List.Nil)) + +(** val translate_cast_signed : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + -> (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_cast_signed globals destrs srca = + Bind_new.Bnew (fun tmp -> + let l = + List.append (sign_mask globals tmp srca) + (translate_move globals destrs + (List.make_list (Joint.Reg tmp) (List.length destrs))) + in + Bind_new.Bret l) + +(** val translate_fill_with_zero : + AST.ident List.list -> Registers.register List.list -> Joint.joint_seq + List.list **) +let translate_fill_with_zero globals destrs = + translate_move globals destrs (Types.pi1 (zero_args (List.length destrs))) + +(** val last : 'a1 List.list -> 'a1 Types.option **) +let rec last = function +| List.Nil -> Types.None +| List.Cons (hd, tl) -> + (match tl with + | List.Nil -> Types.Some hd + | List.Cons (x, x0) -> last tl) + +(** val translate_op_asym_signed : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_op_asym_signed globals op destrs srcrs1 srcrs2 = + Bind_new.Bnew (fun tmp1 -> Bind_new.Bnew (fun tmp2 -> + let l = List.length destrs in + let cast_srcrs = fun srcrs tmp -> + let srcrs_l = List.length srcrs in + (match Nat.leb (Nat.S srcrs_l) l with + | Bool.True -> + (match last srcrs with + | Types.None -> + { Types.fst = + (List.make_list + (let x = Joint.psd_argument_from_byte Joint.zero_byte in x) + l); Types.snd = List.Nil } + | Types.Some last0 -> + { Types.fst = + (List.append srcrs + (List.make_list (Joint.Reg tmp) (Nat.minus l srcrs_l))); + Types.snd = (sign_mask globals tmp last0) }) + | Bool.False -> + { Types.fst = (List.lhd srcrs l); Types.snd = List.Nil }) + in + let srcrs1init = cast_srcrs srcrs1 tmp1 in + let srcrs2init = cast_srcrs srcrs2 tmp2 in + BindLists.bappend (let l0 = srcrs1init.Types.snd in Bind_new.Bret l0) + (BindLists.bappend (let l0 = srcrs2init.Types.snd in Bind_new.Bret l0) + (let l0 = + translate_op globals op destrs srcrs1init.Types.fst + srcrs2init.Types.fst + in + Bind_new.Bret l0)))) + +(** val translate_cast : + AST.ident List.list -> AST.signedness -> Registers.register List.list -> + Registers.register List.list -> (Registers.register, Joint.joint_seq + List.list) Bind_new.bind_new **) +let translate_cast globals src_sign destrs srcrs = + let t = Util.reduce_strong srcrs destrs in + let src_common = t.Types.fst.Types.fst in + let src_rest = t.Types.fst.Types.snd in + let dst_common = t.Types.snd.Types.fst in + let dst_rest = t.Types.snd.Types.snd in + BindLists.bappend + (let l = + translate_move globals dst_common + (List.map (fun x -> Joint.Reg x) src_common) + in + Bind_new.Bret l) + (match src_rest with + | List.Nil -> + (match src_sign with + | AST.Signed -> + (match last srcrs with + | Types.None -> + let l = translate_fill_with_zero globals dst_rest in + Bind_new.Bret l + | Types.Some src_last -> + translate_cast_signed globals dst_rest + (Joint.psd_argument_from_reg src_last)) + | AST.Unsigned -> + let l = translate_fill_with_zero globals dst_rest in + Bind_new.Bret l) + | List.Cons (x, x0) -> let l = List.Nil in Bind_new.Bret l) + +(** val translate_notint : + AST.ident List.list -> Registers.register List.list -> Registers.register + List.list -> Joint.joint_seq List.list **) +let translate_notint globals destrs srcrs = + Util.map2 (fun x x0 -> Joint.OP1 (BackEndOps.Cmpl, x, x0)) + (Obj.magic destrs) (Obj.magic srcrs) + +(** val translate_negint : + AST.ident List.list -> Registers.register List.list -> Registers.register + List.list -> Joint.joint_seq List.list **) +let translate_negint globals destrs srcrs = + List.append (translate_notint globals destrs srcrs) + (translate_op globals BackEndOps.Add destrs + (List.map (fun x -> Joint.Reg x) destrs) + (Types.pi1 (one_args (List.length destrs)))) + +(** val translate_notbool : + AST.ident List.list -> Registers.register List.list -> Registers.register + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new **) +let translate_notbool globals destrs srcrs = + match destrs with + | List.Nil -> let l = List.Nil in Bind_new.Bret l + | List.Cons (destr, destrs') -> + BindLists.bappend + (let l = translate_fill_with_zero globals destrs' in Bind_new.Bret l) + (match srcrs with + | List.Nil -> + let l = List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = destr; Types.snd = + (Joint.psd_argument_from_byte Joint.zero_byte) })), List.Nil) + in + Bind_new.Bret l + | List.Cons (srcr, srcrs') -> + BindLists.bappend + (BindLists.bcons (Joint.MOVE + (Obj.magic { Types.fst = destr; Types.snd = + (Joint.psd_argument_from_reg srcr) })) + (let l = + List.map (fun r -> Joint.OP2 (BackEndOps.Or, + (Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_reg destr)), + (Obj.magic (Joint.psd_argument_from_reg r)))) srcrs' + in + Bind_new.Bret l)) + (BindLists.bcons Joint.CLEAR_CARRY (Bind_new.Bnew (fun tmp -> + let l = List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = tmp; Types.snd = + (Joint.psd_argument_from_byte Joint.zero_byte) })), + (List.Cons ((Joint.OP2 (BackEndOps.Sub, (Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_reg tmp)), + (Obj.magic (Joint.psd_argument_from_reg tmp)))), (List.Cons + ((Joint.OP2 (BackEndOps.Addc, (Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_reg tmp)), + (Obj.magic (Joint.psd_argument_from_reg tmp)))), List.Nil))))) + in + Bind_new.Bret l)))) + +(** val translate_op1 : + AST.ident List.list -> AST.typ -> AST.typ -> FrontEndOps.unary_operation + -> Registers.register List.list -> Registers.register List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_op1 globals ty ty' op1 destrs srcrs = + (match op1 with + | FrontEndOps.Ocastint (x, src_sign, x0, x1) -> + (fun _ _ -> translate_cast globals src_sign destrs srcrs) + | FrontEndOps.Onegint (sz, sg) -> + (fun _ _ -> + let l = translate_negint globals destrs srcrs in Bind_new.Bret l) + | FrontEndOps.Onotbool (x, x0, x1) -> + (fun _ _ -> translate_notbool globals destrs srcrs) + | FrontEndOps.Onotint (sz, sg) -> + (fun _ _ -> + let l = translate_notint globals destrs srcrs in Bind_new.Bret l) + | FrontEndOps.Oid t -> + (fun _ _ -> + let l = + translate_move globals destrs + (List.map (fun x -> Joint.Reg x) srcrs) + in + Bind_new.Bret l) + | FrontEndOps.Optrofint (sz, sg) -> + (fun _ _ -> translate_cast globals AST.Unsigned destrs srcrs) + | FrontEndOps.Ointofptr (sz, sg) -> + (fun _ _ -> translate_cast globals AST.Unsigned destrs srcrs)) __ __ + +(** val translate_mul_i : + AST.ident List.list -> Registers.register -> Registers.register -> + Nat.nat -> Registers.register List.list -> Joint.psd_argument List.list + -> Joint.psd_argument List.list -> Nat.nat -> Nat.nat Types.sig0 -> + Joint.joint_seq List.list -> Joint.joint_seq List.list **) +let translate_mul_i globals a b n tmp_destrs_dummy srcrs1 srcrs2 k i_sig acc = + let i = i_sig in + let args = + List.append (List.Cons ((Joint.Reg a), (List.Cons ((Joint.Reg b), + List.Nil)))) + (List.make_list + (let x = Joint.psd_argument_from_byte Joint.zero_byte in x) + (Nat.minus (Nat.minus n (Nat.S Nat.O)) k)) + in + let tmp_destrs_view = List.ltl tmp_destrs_dummy k in + List.append (List.Cons ((Joint.OPACCS (BackEndOps.Mul, (Obj.magic a), + (Obj.magic b), (Util.nth_safe i (Obj.magic srcrs1)), + (Util.nth_safe (Nat.minus k i) (Obj.magic srcrs2)))), List.Nil)) + (List.append + (translate_op globals BackEndOps.Add tmp_destrs_view + (List.map (fun x -> Joint.Reg x) tmp_destrs_view) args) acc) + +(** val translate_mul : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_mul globals destrs srcrs1 srcrs2 = + Bind_new.Bnew (fun a -> Bind_new.Bnew (fun b -> + Bind_new.bnews_strong (List.length destrs) (fun tmp_destrs _ -> + Bind_new.Bnew (fun dummy -> + BindLists.bcons (Joint.MOVE + (Obj.magic { Types.fst = dummy; Types.snd = + (Joint.psd_argument_from_byte (Joint.byte_of_nat Nat.O)) })) + (let translate_mul_k = fun k_sig acc -> + let k = k_sig in + List.foldr + (translate_mul_i globals a b (List.length destrs) + (List.append tmp_destrs (List.Cons (dummy, List.Nil))) srcrs1 + srcrs2 k) acc (Lists.range_strong (Nat.S k)) + in + let l = + List.append (translate_fill_with_zero globals tmp_destrs) + (List.append + (List.foldr translate_mul_k List.Nil + (Lists.range_strong (List.length destrs))) + (translate_move globals destrs + (List.map (fun x -> Joint.Reg x) tmp_destrs))) + in + Bind_new.Bret l))))) + +(** val translate_divumodu8 : + AST.ident List.list -> Bool.bool -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_divumodu8 globals div_not_mod destrs srcrs1 srcrs2 = + (match destrs with + | List.Nil -> (fun _ -> let l = List.Nil in Bind_new.Bret l) + | List.Cons (destr, destrs') -> + (fun _ -> + match destrs' with + | List.Nil -> + (match srcrs1 with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (srcr1, srcrs1') -> + (fun _ -> + (match srcrs2 with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (srcr2, srcrs2') -> + (fun _ -> Bind_new.Bnew (fun dummy -> + let l = + let { Types.fst = destr1; Types.snd = destr2 } = + match div_not_mod with + | Bool.True -> + { Types.fst = destr; Types.snd = dummy } + | Bool.False -> + { Types.fst = dummy; Types.snd = destr } + in + List.Cons ((Joint.OPACCS (BackEndOps.DivuModu, + (Obj.magic destr1), (Obj.magic destr2), + (Obj.magic srcr1), (Obj.magic srcr2))), List.Nil) + in + Bind_new.Bret l))) __)) __ + | List.Cons (x, x0) -> Logic.false_rect_Type0 __)) __ + +(** val foldr2 : + ('a1 -> 'a2 -> 'a3 -> 'a3) -> 'a3 -> 'a1 List.list -> 'a2 List.list -> + 'a3 **) +let rec foldr2 f init l1 l2 = + (match l1 with + | List.Nil -> (fun _ -> init) + | List.Cons (a, l1') -> + (fun _ -> + (match l2 with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (b, l2') -> (fun _ -> f a b (foldr2 f init l1' l2'))) __)) + __ + +(** val translate_ne : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_ne globals destrs srcrs1 srcrs2 = + (match destrs with + | List.Nil -> (fun _ -> let l = List.Nil in Bind_new.Bret l) + | List.Cons (destr, destrs') -> + (fun _ -> + BindLists.bappend + (let l = translate_fill_with_zero globals destrs' in + Bind_new.Bret l) + ((match srcrs1 with + | List.Nil -> + (fun _ -> + let l = List.Cons ((Joint.MOVE + (Obj.magic { Types.fst = destr; Types.snd = + (Joint.psd_argument_from_byte Joint.zero_byte) })), + List.Nil) + in + Bind_new.Bret l) + | List.Cons (srcr1, srcrs1') -> + (match srcrs2 with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (srcr2, srcrs2') -> + (fun _ -> Bind_new.Bnew (fun tmpr -> + let f = fun s1 s2 acc -> List.Cons ((Joint.OP2 + (BackEndOps.Xor, (Obj.magic tmpr), s1, s2)), (List.Cons + ((Joint.OP2 (BackEndOps.Or, (Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_reg destr)), + (Obj.magic (Joint.psd_argument_from_reg tmpr)))), acc))) + in + let epilogue = List.Cons (Joint.CLEAR_CARRY, (List.Cons + ((Joint.OP2 (BackEndOps.Sub, (Obj.magic tmpr), + (Obj.magic + (Joint.psd_argument_from_byte Joint.zero_byte)), + (Obj.magic (Joint.psd_argument_from_reg destr)))), + (List.Cons ((Joint.OP2 (BackEndOps.Addc, + (Obj.magic destr), + (Obj.magic + (Joint.psd_argument_from_byte Joint.zero_byte)), + (Obj.magic + (Joint.psd_argument_from_byte Joint.zero_byte)))), + List.Nil))))) + in + let l = List.Cons ((Joint.OP2 (BackEndOps.Xor, + (Obj.magic destr), (Obj.magic srcr1), + (Obj.magic srcr2))), + (foldr2 f epilogue (Obj.magic srcrs1') + (Obj.magic srcrs2'))) + in + Bind_new.Bret l)))) __))) __ + +(** val translate_toggle_bool : + AST.ident List.list -> Registers.register List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_toggle_bool globals destrs = + (match destrs with + | List.Nil -> (fun _ -> let l = List.Nil in Bind_new.Bret l) + | List.Cons (destr, x) -> + (fun _ -> + let l = List.Cons ((Joint.OP2 (BackEndOps.Xor, (Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_reg destr)), + (Obj.magic + (Joint.psd_argument_from_byte (Joint.byte_of_nat (Nat.S Nat.O)))))), + List.Nil) + in + Bind_new.Bret l)) __ + +(** val translate_lt_unsigned : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_lt_unsigned globals destrs srcrs1 srcrs2 = + match destrs with + | List.Nil -> let l = List.Nil in Bind_new.Bret l + | List.Cons (destr, destrs') -> + Bind_new.Bnew (fun tmpr -> + BindLists.bappend + (let l = translate_fill_with_zero globals destrs' in Bind_new.Bret l) + (BindLists.bappend + (let l = + translate_op globals BackEndOps.Sub + (List.make_list tmpr (List.length srcrs1)) srcrs1 srcrs2 + in + Bind_new.Bret l) + (let l = List.Cons ((Joint.OP2 (BackEndOps.Addc, (Obj.magic destr), + (Obj.magic (Joint.psd_argument_from_byte Joint.zero_byte)), + (Obj.magic (Joint.psd_argument_from_byte Joint.zero_byte)))), + List.Nil) + in + Bind_new.Bret l))) + +(** val shift_signed : + AST.ident List.list -> Registers.register -> Joint.psd_argument List.list + -> (Joint.psd_argument List.list, Joint.joint_seq List.list) Types.prod + Types.sig0 **) +let rec shift_signed globals tmp srcrs = + let byte_128 = Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), Bool.True, + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) + in + (match srcrs with + | List.Nil -> (fun _ -> { Types.fst = List.Nil; Types.snd = List.Nil }) + | List.Cons (srcr, srcrs') -> + (fun _ -> + (match srcrs' with + | List.Nil -> + (fun _ -> { Types.fst = (List.Cons ((Joint.Reg tmp), List.Nil)); + Types.snd = (List.Cons ((Joint.OP2 (BackEndOps.Add, + (Obj.magic tmp), (Obj.magic srcr), + (Obj.magic (Joint.psd_argument_from_byte byte_128)))), + List.Nil)) }) + | List.Cons (x, x0) -> + (fun _ -> + let re = shift_signed globals tmp srcrs' in + { Types.fst = (List.Cons (srcr, (Types.pi1 re).Types.fst)); + Types.snd = (Types.pi1 re).Types.snd })) __)) __ + +(** val translate_lt_signed : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_lt_signed globals destrs srcrs1 srcrs2 = + Bind_new.Bnew (fun tmp_last_s1 -> Bind_new.Bnew (fun tmp_last_s2 -> + let p1 = shift_signed globals tmp_last_s1 srcrs1 in + let new_srcrs1 = (Types.pi1 p1).Types.fst in + let shift_srcrs1 = (Types.pi1 p1).Types.snd in + let p2 = shift_signed globals tmp_last_s2 srcrs2 in + let new_srcrs2 = (Types.pi1 p2).Types.fst in + let shift_srcrs2 = (Types.pi1 p2).Types.snd in + BindLists.bappend (let l = shift_srcrs1 in Bind_new.Bret l) + (BindLists.bappend (let l = shift_srcrs2 in Bind_new.Bret l) + (translate_lt_unsigned globals destrs new_srcrs1 new_srcrs2)))) + +(** val translate_lt : + Bool.bool -> AST.ident List.list -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_lt is_unsigned globals destrs srcrs1 srcrs2 = + match is_unsigned with + | Bool.True -> translate_lt_unsigned globals destrs srcrs1 srcrs2 + | Bool.False -> translate_lt_signed globals destrs srcrs1 srcrs2 + +(** val translate_cmp : + Bool.bool -> AST.ident List.list -> Integers.comparison -> + Registers.register List.list -> Joint.psd_argument List.list -> + Joint.psd_argument List.list -> (Registers.register, Joint.joint_seq) + BindLists.bind_list **) +let translate_cmp is_unsigned globals cmp destrs srcrs1 srcrs2 = + match cmp with + | Integers.Ceq -> + BindLists.bappend (translate_ne globals destrs srcrs1 srcrs2) + (translate_toggle_bool globals destrs) + | Integers.Cne -> translate_ne globals destrs srcrs1 srcrs2 + | Integers.Clt -> translate_lt is_unsigned globals destrs srcrs1 srcrs2 + | Integers.Cle -> + BindLists.bappend (translate_lt is_unsigned globals destrs srcrs2 srcrs1) + (translate_toggle_bool globals destrs) + | Integers.Cgt -> translate_lt is_unsigned globals destrs srcrs2 srcrs1 + | Integers.Cge -> + BindLists.bappend (translate_lt is_unsigned globals destrs srcrs1 srcrs2) + (translate_toggle_bool globals destrs) + +(** val translate_op2 : + AST.ident List.list -> AST.typ -> AST.typ -> AST.typ -> + FrontEndOps.binary_operation -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new **) +let translate_op2 globals ty1 ty2 ty3 op2 destrs srcrs1 srcrs2 = + (match op2 with + | FrontEndOps.Oadd (sz, sg) -> + (fun _ _ _ -> + let l = translate_op globals BackEndOps.Add destrs srcrs1 srcrs2 in + Bind_new.Bret l) + | FrontEndOps.Osub (sz, sg) -> + (fun _ _ _ -> + let l = translate_op globals BackEndOps.Sub destrs srcrs1 srcrs2 in + Bind_new.Bret l) + | FrontEndOps.Omul (sz, sg) -> + (fun _ _ _ -> translate_mul globals destrs srcrs1 srcrs2) + | FrontEndOps.Odiv x -> assert false (* absurd case *) + | FrontEndOps.Odivu sz -> + (fun _ _ _ -> + translate_divumodu8 globals Bool.True destrs srcrs1 srcrs2) + | FrontEndOps.Omod x -> assert false (* absurd case *) + | FrontEndOps.Omodu sz -> + (fun _ _ _ -> + translate_divumodu8 globals Bool.False destrs srcrs1 srcrs2) + | FrontEndOps.Oand (sz, sg) -> + (fun _ _ _ -> + let l = translate_op globals BackEndOps.And destrs srcrs1 srcrs2 in + Bind_new.Bret l) + | FrontEndOps.Oor (sz, sg) -> + (fun _ _ _ -> + let l = translate_op globals BackEndOps.Or destrs srcrs1 srcrs2 in + Bind_new.Bret l) + | FrontEndOps.Oxor (sz, sg) -> + (fun _ _ _ -> + let l = translate_op globals BackEndOps.Xor destrs srcrs1 srcrs2 in + Bind_new.Bret l) + | FrontEndOps.Oshl (x, x0) -> assert false (* absurd case *) + | FrontEndOps.Oshr (x, x0) -> assert false (* absurd case *) + | FrontEndOps.Oshru (x, x0) -> assert false (* absurd case *) + | FrontEndOps.Ocmp (sz, sg1, sg2, c) -> + (fun _ _ _ -> translate_cmp Bool.False globals c destrs srcrs1 srcrs2) + | FrontEndOps.Ocmpu (sz, sg, c) -> + (fun _ _ _ -> translate_cmp Bool.True globals c destrs srcrs1 srcrs2) + | FrontEndOps.Oaddpi sz -> + (fun _ _ _ -> + translate_op_asym_signed globals BackEndOps.Add destrs srcrs1 srcrs2) + | FrontEndOps.Oaddip sz -> + (fun _ _ _ -> + translate_op_asym_signed globals BackEndOps.Add destrs srcrs2 srcrs1) + | FrontEndOps.Osubpi sz -> + (fun _ _ _ -> + translate_op_asym_signed globals BackEndOps.Add destrs srcrs1 srcrs2) + | FrontEndOps.Osubpp sz -> + (fun _ _ _ -> + let l = + translate_op_asym_unsigned globals BackEndOps.Sub destrs srcrs1 + srcrs2 + in + Bind_new.Bret l) + | FrontEndOps.Ocmpp (sg, c) -> + (fun _ _ _ -> translate_cmp Bool.True globals c destrs srcrs1 srcrs2)) + __ __ __ + +(** val translate_cond : + AST.ident List.list -> Registers.register List.list -> Graphs.label -> + Blocks.bind_step_block **) +let translate_cond globals srcrs lbl_true = + match srcrs with + | List.Nil -> + Bind_new.Bret + (Blocks.ensure_step_block (Joint.graph_params_to_params RTL.rTL) + globals List.Nil) + | List.Cons (srcr, srcrs') -> + Bind_new.Bnew (fun tmpr -> + let f = fun r x -> Joint.OP2 (BackEndOps.Or, (Obj.magic tmpr), + (Obj.magic (Joint.psd_argument_from_reg tmpr)), + (Obj.magic (Joint.psd_argument_from_reg r))) + in + Bind_new.Bret { Types.fst = { Types.fst = (List.Cons ((fun x -> + Joint.MOVE + (Obj.magic { Types.fst = tmpr; Types.snd = + (Joint.psd_argument_from_reg srcr) })), (List.map f srcrs'))); + Types.snd = (fun x -> Joint.COND ((Obj.magic tmpr), lbl_true)) }; + Types.snd = List.Nil }) + +(** val translate_load : + AST.ident List.list -> Joint.psd_argument List.list -> Registers.register + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new **) +let translate_load globals addr destrs = + Bind_new.Bnew (fun tmp_addr_l -> Bind_new.Bnew (fun tmp_addr_h -> + BindLists.bappend + (let l = + translate_move globals (List.Cons (tmp_addr_l, (List.Cons + (tmp_addr_h, List.Nil)))) addr + in + Bind_new.Bret l) + (let f = fun destr acc -> + BindLists.bappend + (let l = List.Cons ((Joint.LOAD (destr, + (Obj.magic (Joint.Reg tmp_addr_l)), + (Obj.magic (Joint.Reg tmp_addr_h)))), List.Nil) + in + Bind_new.Bret l) + (BindLists.bappend + (let l = + translate_op globals BackEndOps.Add (List.Cons (tmp_addr_l, + (List.Cons (tmp_addr_h, List.Nil)))) (List.Cons + ((Joint.psd_argument_from_reg tmp_addr_l), (List.Cons + ((Joint.psd_argument_from_reg tmp_addr_h), List.Nil)))) + (List.Cons + ((let x = I8051.int_size in Joint.psd_argument_from_byte x), + (List.Cons ((Joint.psd_argument_from_byte Joint.zero_byte), + List.Nil)))) + in + Bind_new.Bret l) acc) + in + List.foldr f (let l = List.Nil in Bind_new.Bret l) (Obj.magic destrs)))) + +(** val translate_store : + AST.ident List.list -> Joint.psd_argument List.list -> Joint.psd_argument + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new **) +let translate_store globals addr srcrs = + Bind_new.Bnew (fun tmp_addr_l -> Bind_new.Bnew (fun tmp_addr_h -> + BindLists.bappend + (let l = + translate_move globals (List.Cons (tmp_addr_l, (List.Cons + (tmp_addr_h, List.Nil)))) addr + in + Bind_new.Bret l) + (let f = fun srcr acc -> + BindLists.bappend + (let l = List.Cons ((Joint.STORE + ((Obj.magic (Joint.Reg tmp_addr_l)), + (Obj.magic (Joint.Reg tmp_addr_h)), srcr)), List.Nil) + in + Bind_new.Bret l) + (BindLists.bappend + (let l = + translate_op globals BackEndOps.Add (List.Cons (tmp_addr_l, + (List.Cons (tmp_addr_h, List.Nil)))) (List.Cons + ((Joint.psd_argument_from_reg tmp_addr_l), (List.Cons + ((Joint.psd_argument_from_reg tmp_addr_h), List.Nil)))) + (List.Cons + ((let x = I8051.int_size in Joint.psd_argument_from_byte x), + (List.Cons ((Joint.psd_argument_from_byte Joint.zero_byte), + List.Nil)))) + in + Bind_new.Bret l) acc) + in + List.foldr f (let l = List.Nil in Bind_new.Bret l) (Obj.magic srcrs)))) + +(** val ensure_bind_step_block : + Joint.params -> AST.ident List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new -> Blocks.bind_step_block **) +let ensure_bind_step_block p g b = + Obj.magic + (Monad.m_bind0 (Monad.max_def Bind_new.bindNew) (Obj.magic b) (fun l -> + Obj.magic (Bind_new.Bret (Blocks.ensure_step_block p g l)))) + +(** val translate_statement : + AST.ident List.list -> (Registers.register, AST.typ) Types.prod List.list + -> local_env -> RTLabs_syntax.statement -> ((Blocks.bind_step_block, + Blocks.bind_fin_block) Types.sum, __) Types.dPair **) +let translate_statement globals locals lenv stmt = + (match stmt with + | RTLabs_syntax.St_skip lbl' -> + (fun _ -> { Types.dpi1 = (Types.Inl (Bind_new.Bret + (Blocks.ensure_step_block (Joint.graph_params_to_params RTL.rTL) + globals List.Nil))); Types.dpi2 = (Obj.magic lbl') }) + | RTLabs_syntax.St_cost (cost_lbl, lbl') -> + (fun _ -> { Types.dpi1 = (Types.Inl (Bind_new.Bret { Types.fst = + { Types.fst = List.Nil; Types.snd = (fun x -> Joint.COST_LABEL + cost_lbl) }; Types.snd = List.Nil })); Types.dpi2 = + (Obj.magic lbl') }) + | RTLabs_syntax.St_const (ty, destr, cst, lbl') -> + (fun _ -> { Types.dpi1 = (Types.Inl + (ensure_bind_step_block (Joint.graph_params_to_params RTL.rTL) globals + (translate_cst ty globals cst (find_local_env destr lenv)))); + Types.dpi2 = (Obj.magic lbl') }) + | RTLabs_syntax.St_op1 (ty, ty', op1, destr, srcr, lbl') -> + (fun _ -> { Types.dpi1 = (Types.Inl + (ensure_bind_step_block (Joint.graph_params_to_params RTL.rTL) globals + (translate_op1 globals ty' ty op1 (find_local_env destr lenv) + (find_local_env srcr lenv)))); Types.dpi2 = (Obj.magic lbl') }) + | RTLabs_syntax.St_op2 (ty1, ty2, ty3, op2, destr, srcr1, srcr2, lbl') -> + (fun _ -> { Types.dpi1 = (Types.Inl + (ensure_bind_step_block (Joint.graph_params_to_params RTL.rTL) globals + (translate_op2 globals ty2 ty3 ty1 op2 (find_local_env destr lenv) + (find_local_env_arg srcr1 lenv) (find_local_env_arg srcr2 lenv)))); + Types.dpi2 = (Obj.magic lbl') }) + | RTLabs_syntax.St_load (ignore, addr, destr, lbl') -> + (fun _ -> { Types.dpi1 = (Types.Inl + (ensure_bind_step_block (Joint.graph_params_to_params RTL.rTL) globals + (translate_load globals (find_local_env_arg addr lenv) + (find_local_env destr lenv)))); Types.dpi2 = (Obj.magic lbl') }) + | RTLabs_syntax.St_store (ignore, addr, srcr, lbl') -> + (fun _ -> { Types.dpi1 = (Types.Inl + (ensure_bind_step_block (Joint.graph_params_to_params RTL.rTL) globals + (translate_store globals (find_local_env_arg addr lenv) + (find_local_env_arg srcr lenv)))); Types.dpi2 = + (Obj.magic lbl') }) + | RTLabs_syntax.St_call_id (f, args, retr, lbl') -> + (fun _ -> { Types.dpi1 = (Types.Inl (Bind_new.Bret { Types.fst = + { Types.fst = List.Nil; Types.snd = (fun x -> Joint.CALL ((Types.Inl + f), (Obj.magic (rtl_args args lenv)), + (match retr with + | Types.None -> Obj.magic List.Nil + | Types.Some retr0 -> Obj.magic (find_local_env retr0 lenv)))) }; + Types.snd = List.Nil })); Types.dpi2 = (Obj.magic lbl') }) + | RTLabs_syntax.St_call_ptr (f, args, retr, lbl') -> + (fun _ -> + let fs = find_and_addr_arg f lenv in + { Types.dpi1 = (Types.Inl (Bind_new.Bret { Types.fst = { Types.fst = + List.Nil; Types.snd = (fun x -> Joint.CALL ((Types.Inr + (Obj.magic fs)), (Obj.magic (rtl_args args lenv)), + (match retr with + | Types.None -> Obj.magic List.Nil + | Types.Some retr0 -> Obj.magic (find_local_env retr0 lenv)))) }; + Types.snd = List.Nil })); Types.dpi2 = (Obj.magic lbl') }) + | RTLabs_syntax.St_cond (r, lbl_true, lbl_false) -> + (fun _ -> { Types.dpi1 = (Types.Inl + (translate_cond globals (find_local_env r lenv) lbl_true)); + Types.dpi2 = (Obj.magic lbl_false) }) + | RTLabs_syntax.St_return -> + (fun _ -> { Types.dpi1 = (Types.Inr (Bind_new.Bret { Types.fst = + List.Nil; Types.snd = Joint.RETURN })); Types.dpi2 = + (Obj.magic Types.It) })) __ + +(** val translate_internal : + AST.ident List.list -> RTLabs_syntax.internal_function -> + Joint.joint_closed_internal_function **) +let translate_internal globals def = + let runiverse' = def.RTLabs_syntax.f_reggen in + let luniverse' = def.RTLabs_syntax.f_labgen in + let stack_size' = def.RTLabs_syntax.f_stacksize in + let entry' = Types.pi1 def.RTLabs_syntax.f_entry in + let init = { Joint.joint_if_luniverse = luniverse'; + Joint.joint_if_runiverse = runiverse'; Joint.joint_if_result = + (Obj.magic List.Nil); Joint.joint_if_params = (Obj.magic List.Nil); + Joint.joint_if_stacksize = stack_size'; Joint.joint_if_local_stacksize = + stack_size'; Joint.joint_if_code = + (Obj.magic + (Identifiers.add PreIdentifiers.LabelTag + (Identifiers.empty_map PreIdentifiers.LabelTag) entry' (Joint.Final + Joint.RETURN))); Joint.joint_if_entry = (Obj.magic entry') } + in + (let { Types.fst = init'; Types.snd = lenv } = + Obj.magic initialize_locals_params_ret globals + def.RTLabs_syntax.f_locals def.RTLabs_syntax.f_params + def.RTLabs_syntax.f_result init + in + (fun _ -> + let vars = + List.append def.RTLabs_syntax.f_locals + (List.append def.RTLabs_syntax.f_params + (match def.RTLabs_syntax.f_result with + | Types.None -> List.Nil + | Types.Some x -> List.Cons (x, List.Nil))) + in + let f_trans = fun lbl stmt def0 -> + let pr = translate_statement globals vars lenv stmt in + (match pr.Types.dpi1 with + | Types.Inl instrs -> + (fun lbl' -> + TranslateUtils.b_adds_graph RTL.rTL globals instrs lbl + (Obj.magic lbl') def0) + | Types.Inr instrs -> + (fun x -> + TranslateUtils.b_fin_adds_graph RTL.rTL globals instrs lbl def0)) + pr.Types.dpi2 + in + Identifiers.foldi PreIdentifiers.LabelTag f_trans def.RTLabs_syntax.f_graph + init')) __ + +(** val rtlabs_to_rtl : + CostLabel.costlabel -> RTLabs_syntax.rTLabs_program -> RTL.rtl_program **) +let rtlabs_to_rtl init_cost p = + { Joint.jp_functions = (AST.prog_funct_names p); Joint.joint_prog = + (AST.transform_program p (fun varnames -> + AST.transf_fundef + (translate_internal (List.append varnames (AST.prog_funct_names p))))); + Joint.init_cost_label = init_cost } + diff --git a/extracted/rTLabsToRTL.mli b/extracted/rTLabsToRTL.mli new file mode 100644 index 0000000..7bdfcff --- /dev/null +++ b/extracted/rTLabsToRTL.mli @@ -0,0 +1,409 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open RTLabs_syntax + +open Extra_bool + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open I8051 + +open BackEndOps + +open Joint + +open RTL + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +val size_of_sig_type : AST.typ -> Nat.nat + +val sign_of_sig_type : AST.typ -> AST.signedness + +type register_type = +| Register_int of Registers.register +| Register_ptr of Registers.register * Registers.register + +val register_type_rect_Type4 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register -> + 'a1) -> register_type -> 'a1 + +val register_type_rect_Type5 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register -> + 'a1) -> register_type -> 'a1 + +val register_type_rect_Type3 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register -> + 'a1) -> register_type -> 'a1 + +val register_type_rect_Type2 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register -> + 'a1) -> register_type -> 'a1 + +val register_type_rect_Type1 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register -> + 'a1) -> register_type -> 'a1 + +val register_type_rect_Type0 : + (Registers.register -> 'a1) -> (Registers.register -> Registers.register -> + 'a1) -> register_type -> 'a1 + +val register_type_inv_rect_Type4 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 + +val register_type_inv_rect_Type3 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 + +val register_type_inv_rect_Type2 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 + +val register_type_inv_rect_Type1 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 + +val register_type_inv_rect_Type0 : + register_type -> (Registers.register -> __ -> 'a1) -> (Registers.register + -> Registers.register -> __ -> 'a1) -> 'a1 + +val register_type_discr : register_type -> register_type -> __ + +val register_type_jmdiscr : register_type -> register_type -> __ + +type local_env = Registers.register List.list Identifiers.identifier_map + +val find_local_env : + PreIdentifiers.identifier -> local_env -> Registers.register List.list + +val find_local_env_arg : + Registers.register -> local_env -> Joint.psd_argument List.list + +val m_iter : Monad.monad -> ('a1 -> __) -> Nat.nat -> __ -> __ + +val fresh_registers : + Joint.params -> AST.ident List.list -> Nat.nat -> Registers.register + List.list Monad.smax_def__o__monad + +val map_list_local_env : + Registers.register List.list Identifiers.identifier_map -> + (Registers.register, AST.typ) Types.prod List.list -> Registers.register + List.list + +val initialize_local_env : + AST.ident List.list -> (Registers.register, AST.typ) Types.prod List.list + -> local_env Monad.smax_def__o__monad + +val initialize_locals_params_ret : + AST.ident List.list -> (Registers.register, AST.typ) Types.prod List.list + -> (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod Types.option -> local_env + Monad.smax_def__o__monad + +val make_addr : 'a1 List.list -> ('a1, 'a1) Types.prod + +val find_and_addr : + PreIdentifiers.identifier -> local_env -> (Registers.register, + Registers.register) Types.prod + +val find_and_addr_arg : + Registers.register -> local_env -> (Joint.psd_argument, Joint.psd_argument) + Types.prod + +val rtl_args : + Registers.register List.list -> local_env -> Joint.psd_argument List.list + +val vrsplit : + Nat.nat -> Nat.nat -> 'a1 Vector.vector -> 'a1 Vector.vector List.list + Types.sig0 + +val split_into_bytes : + AST.intsize -> AST.bvint -> BitVector.byte List.list Types.sig0 + +val list_inject_All_aux : 'a1 List.list -> 'a1 Types.sig0 List.list + +val translate_op_aux : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + Joint.joint_seq List.list + +val translate_op : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + Joint.joint_seq List.list + +val cast_list : 'a1 -> Nat.nat -> 'a1 List.list -> 'a1 List.list + +val translate_op_asym_unsigned : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + Joint.joint_seq List.list + +val zero_args : Nat.nat -> Joint.psd_argument List.list Types.sig0 + +val one_args : Nat.nat -> Joint.psd_argument List.list Types.sig0 + +val size_of_cst : AST.typ -> FrontEndOps.constant -> Nat.nat + +val translate_cst : + AST.typ -> AST.ident List.list -> FrontEndOps.constant Types.sig0 -> + Registers.register List.list -> (Registers.register, Joint.joint_seq + List.list) Bind_new.bind_new + +val translate_move : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.joint_seq List.list + +val sign_mask : + AST.ident List.list -> Registers.register -> Joint.psd_argument -> + Joint.joint_seq List.list + +val translate_cast_signed : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + -> (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +val translate_fill_with_zero : + AST.ident List.list -> Registers.register List.list -> Joint.joint_seq + List.list + +val last : 'a1 List.list -> 'a1 Types.option + +val translate_op_asym_signed : + AST.ident List.list -> BackEndOps.op2 -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +val translate_cast : + AST.ident List.list -> AST.signedness -> Registers.register List.list -> + Registers.register List.list -> (Registers.register, Joint.joint_seq + List.list) Bind_new.bind_new + +val translate_notint : + AST.ident List.list -> Registers.register List.list -> Registers.register + List.list -> Joint.joint_seq List.list + +val translate_negint : + AST.ident List.list -> Registers.register List.list -> Registers.register + List.list -> Joint.joint_seq List.list + +val translate_notbool : + AST.ident List.list -> Registers.register List.list -> Registers.register + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new + +val translate_op1 : + AST.ident List.list -> AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register List.list -> Registers.register List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +val translate_mul_i : + AST.ident List.list -> Registers.register -> Registers.register -> Nat.nat + -> Registers.register List.list -> Joint.psd_argument List.list -> + Joint.psd_argument List.list -> Nat.nat -> Nat.nat Types.sig0 -> + Joint.joint_seq List.list -> Joint.joint_seq List.list + +val translate_mul : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new + +val translate_divumodu8 : + AST.ident List.list -> Bool.bool -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +val foldr2 : + ('a1 -> 'a2 -> 'a3 -> 'a3) -> 'a3 -> 'a1 List.list -> 'a2 List.list -> 'a3 + +val translate_ne : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new + +val translate_toggle_bool : + AST.ident List.list -> Registers.register List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new + +val translate_lt_unsigned : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new + +val shift_signed : + AST.ident List.list -> Registers.register -> Joint.psd_argument List.list + -> (Joint.psd_argument List.list, Joint.joint_seq List.list) Types.prod + Types.sig0 + +val translate_lt_signed : + AST.ident List.list -> Registers.register List.list -> Joint.psd_argument + List.list -> Joint.psd_argument List.list -> (Registers.register, + Joint.joint_seq List.list) Bind_new.bind_new + +val translate_lt : + Bool.bool -> AST.ident List.list -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +val translate_cmp : + Bool.bool -> AST.ident List.list -> Integers.comparison -> + Registers.register List.list -> Joint.psd_argument List.list -> + Joint.psd_argument List.list -> (Registers.register, Joint.joint_seq) + BindLists.bind_list + +val translate_op2 : + AST.ident List.list -> AST.typ -> AST.typ -> AST.typ -> + FrontEndOps.binary_operation -> Registers.register List.list -> + Joint.psd_argument List.list -> Joint.psd_argument List.list -> + (Registers.register, Joint.joint_seq List.list) Bind_new.bind_new + +val translate_cond : + AST.ident List.list -> Registers.register List.list -> Graphs.label -> + Blocks.bind_step_block + +val translate_load : + AST.ident List.list -> Joint.psd_argument List.list -> Registers.register + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new + +val translate_store : + AST.ident List.list -> Joint.psd_argument List.list -> Joint.psd_argument + List.list -> (Registers.register, Joint.joint_seq List.list) + Bind_new.bind_new + +val ensure_bind_step_block : + Joint.params -> AST.ident List.list -> (Registers.register, Joint.joint_seq + List.list) Bind_new.bind_new -> Blocks.bind_step_block + +val translate_statement : + AST.ident List.list -> (Registers.register, AST.typ) Types.prod List.list + -> local_env -> RTLabs_syntax.statement -> ((Blocks.bind_step_block, + Blocks.bind_fin_block) Types.sum, __) Types.dPair + +val translate_internal : + AST.ident List.list -> RTLabs_syntax.internal_function -> + Joint.joint_closed_internal_function + +val rtlabs_to_rtl : + CostLabel.costlabel -> RTLabs_syntax.rTLabs_program -> RTL.rtl_program + diff --git a/extracted/rTLabs_abstract.ml b/extracted/rTLabs_abstract.ml new file mode 100644 index 0000000..3c7e969 --- /dev/null +++ b/extracted/rTLabs_abstract.ml @@ -0,0 +1,615 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +open SmallstepExec + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open RTLabs_semantics + +type rTLabs_state = RTLabs_semantics.state + +type rTLabs_genv = RTLabs_semantics.genv + +open Sets + +open Listb + +open StructuredTraces + +open CostSpec + +open Deqsets_extra + +(** val status_class_jmdiscr : + StructuredTraces.status_class -> StructuredTraces.status_class -> __ **) +let status_class_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | StructuredTraces.Cl_return -> Obj.magic (fun _ dH -> dH) + | StructuredTraces.Cl_jump -> Obj.magic (fun _ dH -> dH) + | StructuredTraces.Cl_call -> Obj.magic (fun _ dH -> dH) + | StructuredTraces.Cl_tailcall -> Obj.magic (fun _ dH -> dH) + | StructuredTraces.Cl_other -> Obj.magic (fun _ dH -> dH)) y + +type rTLabs_ext_state = { ras_state : RTLabs_semantics.state; + ras_fn_stack : Pointers.block List.list } + +(** val rTLabs_ext_state_rect_Type4 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 **) +let rec rTLabs_ext_state_rect_Type4 ge h_mk_RTLabs_ext_state x_24320 = + let { ras_state = ras_state0; ras_fn_stack = ras_fn_stack0 } = x_24320 in + h_mk_RTLabs_ext_state ras_state0 ras_fn_stack0 __ + +(** val rTLabs_ext_state_rect_Type5 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 **) +let rec rTLabs_ext_state_rect_Type5 ge h_mk_RTLabs_ext_state x_24322 = + let { ras_state = ras_state0; ras_fn_stack = ras_fn_stack0 } = x_24322 in + h_mk_RTLabs_ext_state ras_state0 ras_fn_stack0 __ + +(** val rTLabs_ext_state_rect_Type3 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 **) +let rec rTLabs_ext_state_rect_Type3 ge h_mk_RTLabs_ext_state x_24324 = + let { ras_state = ras_state0; ras_fn_stack = ras_fn_stack0 } = x_24324 in + h_mk_RTLabs_ext_state ras_state0 ras_fn_stack0 __ + +(** val rTLabs_ext_state_rect_Type2 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 **) +let rec rTLabs_ext_state_rect_Type2 ge h_mk_RTLabs_ext_state x_24326 = + let { ras_state = ras_state0; ras_fn_stack = ras_fn_stack0 } = x_24326 in + h_mk_RTLabs_ext_state ras_state0 ras_fn_stack0 __ + +(** val rTLabs_ext_state_rect_Type1 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 **) +let rec rTLabs_ext_state_rect_Type1 ge h_mk_RTLabs_ext_state x_24328 = + let { ras_state = ras_state0; ras_fn_stack = ras_fn_stack0 } = x_24328 in + h_mk_RTLabs_ext_state ras_state0 ras_fn_stack0 __ + +(** val rTLabs_ext_state_rect_Type0 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 **) +let rec rTLabs_ext_state_rect_Type0 ge h_mk_RTLabs_ext_state x_24330 = + let { ras_state = ras_state0; ras_fn_stack = ras_fn_stack0 } = x_24330 in + h_mk_RTLabs_ext_state ras_state0 ras_fn_stack0 __ + +(** val ras_state : + RTLabs_semantics.genv -> rTLabs_ext_state -> RTLabs_semantics.state **) +let rec ras_state ge xxx = + xxx.ras_state + +(** val ras_fn_stack : + RTLabs_semantics.genv -> rTLabs_ext_state -> Pointers.block List.list **) +let rec ras_fn_stack ge xxx = + xxx.ras_fn_stack + +(** val rTLabs_ext_state_inv_rect_Type4 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 **) +let rTLabs_ext_state_inv_rect_Type4 x1 hterm h1 = + let hcut = rTLabs_ext_state_rect_Type4 x1 h1 hterm in hcut __ + +(** val rTLabs_ext_state_inv_rect_Type3 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 **) +let rTLabs_ext_state_inv_rect_Type3 x1 hterm h1 = + let hcut = rTLabs_ext_state_rect_Type3 x1 h1 hterm in hcut __ + +(** val rTLabs_ext_state_inv_rect_Type2 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 **) +let rTLabs_ext_state_inv_rect_Type2 x1 hterm h1 = + let hcut = rTLabs_ext_state_rect_Type2 x1 h1 hterm in hcut __ + +(** val rTLabs_ext_state_inv_rect_Type1 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 **) +let rTLabs_ext_state_inv_rect_Type1 x1 hterm h1 = + let hcut = rTLabs_ext_state_rect_Type1 x1 h1 hterm in hcut __ + +(** val rTLabs_ext_state_inv_rect_Type0 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 **) +let rTLabs_ext_state_inv_rect_Type0 x1 hterm h1 = + let hcut = rTLabs_ext_state_rect_Type0 x1 h1 hterm in hcut __ + +(** val rTLabs_ext_state_discr : + RTLabs_semantics.genv -> rTLabs_ext_state -> rTLabs_ext_state -> __ **) +let rTLabs_ext_state_discr a1 x y = + Logic.eq_rect_Type2 x + (let { ras_state = a0; ras_fn_stack = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val rTLabs_ext_state_jmdiscr : + RTLabs_semantics.genv -> rTLabs_ext_state -> rTLabs_ext_state -> __ **) +let rTLabs_ext_state_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { ras_state = a0; ras_fn_stack = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val dpi1__o__Ras_state__o__inject : + RTLabs_semantics.genv -> (rTLabs_ext_state, 'a1) Types.dPair -> + RTLabs_semantics.state Types.sig0 **) +let dpi1__o__Ras_state__o__inject x1 x3 = + x3.Types.dpi1.ras_state + +(** val eject__o__Ras_state__o__inject : + RTLabs_semantics.genv -> rTLabs_ext_state Types.sig0 -> + RTLabs_semantics.state Types.sig0 **) +let eject__o__Ras_state__o__inject x1 x3 = + (Types.pi1 x3).ras_state + +(** val ras_state__o__inject : + RTLabs_semantics.genv -> rTLabs_ext_state -> RTLabs_semantics.state + Types.sig0 **) +let ras_state__o__inject x1 x2 = + x2.ras_state + +(** val dpi1__o__Ras_state : + RTLabs_semantics.genv -> (rTLabs_ext_state, 'a1) Types.dPair -> + RTLabs_semantics.state **) +let dpi1__o__Ras_state x0 x2 = + x2.Types.dpi1.ras_state + +(** val eject__o__Ras_state : + RTLabs_semantics.genv -> rTLabs_ext_state Types.sig0 -> + RTLabs_semantics.state **) +let eject__o__Ras_state x0 x2 = + (Types.pi1 x2).ras_state + +(** val next_state : + RTLabs_semantics.genv -> rTLabs_ext_state -> RTLabs_semantics.state -> + Events.trace -> rTLabs_ext_state **) +let next_state ge s s' t = + { ras_state = s'; ras_fn_stack = + ((match s' with + | RTLabs_semantics.State (x, x0, x1) -> (fun _ -> s.ras_fn_stack) + | RTLabs_semantics.Callstate (x, x0, x1, x2, x3, x4) -> + (fun _ -> List.Cons + ((Types.pi1 + (RTLabs_semantics.func_block_of_exec ge s.ras_state t x x0 x1 x2 + x3 x4)), s.ras_fn_stack)) + | RTLabs_semantics.Returnstate (x, x0, x1, x2) -> + (fun _ -> List.tail s.ras_fn_stack) + | RTLabs_semantics.Finalstate x -> (fun _ -> List.Nil)) __) } + +(** val rTLabs_classify : + RTLabs_semantics.state -> StructuredTraces.status_class **) +let rTLabs_classify = function +| RTLabs_semantics.State (f, x, x0) -> + (match RTLabs_semantics.next_instruction f with + | RTLabs_syntax.St_skip x1 -> StructuredTraces.Cl_other + | RTLabs_syntax.St_cost (x1, x2) -> StructuredTraces.Cl_other + | RTLabs_syntax.St_const (x1, x2, x3, x4) -> StructuredTraces.Cl_other + | RTLabs_syntax.St_op1 (x1, x2, x3, x4, x5, x6) -> + StructuredTraces.Cl_other + | RTLabs_syntax.St_op2 (x1, x2, x3, x4, x5, x6, x7, x8) -> + StructuredTraces.Cl_other + | RTLabs_syntax.St_load (x1, x2, x3, x4) -> StructuredTraces.Cl_other + | RTLabs_syntax.St_store (x1, x2, x3, x4) -> StructuredTraces.Cl_other + | RTLabs_syntax.St_call_id (x1, x2, x3, x4) -> StructuredTraces.Cl_other + | RTLabs_syntax.St_call_ptr (x1, x2, x3, x4) -> StructuredTraces.Cl_other + | RTLabs_syntax.St_cond (x1, x2, x3) -> StructuredTraces.Cl_jump + | RTLabs_syntax.St_return -> StructuredTraces.Cl_other) +| RTLabs_semantics.Callstate (x, x0, x1, x2, x3, x4) -> + StructuredTraces.Cl_call +| RTLabs_semantics.Returnstate (x, x0, x1, x2) -> StructuredTraces.Cl_return +| RTLabs_semantics.Finalstate x -> StructuredTraces.Cl_other + +(** val rTLabs_cost : RTLabs_semantics.state -> Bool.bool **) +let rTLabs_cost = function +| RTLabs_semantics.State (f, fs, m) -> + CostSpec.is_cost_label (RTLabs_semantics.next_instruction f) +| RTLabs_semantics.Callstate (x, x0, x1, x2, x3, x4) -> Bool.False +| RTLabs_semantics.Returnstate (x, x0, x1, x2) -> Bool.False +| RTLabs_semantics.Finalstate x -> Bool.False + +(** val rTLabs_cost_label : + RTLabs_semantics.state -> CostLabel.costlabel Types.option **) +let rTLabs_cost_label = function +| RTLabs_semantics.State (f, fs, m) -> + CostSpec.cost_label_of (RTLabs_semantics.next_instruction f) +| RTLabs_semantics.Callstate (x, x0, x1, x2, x3, x4) -> Types.None +| RTLabs_semantics.Returnstate (x, x0, x1, x2) -> Types.None +| RTLabs_semantics.Finalstate x -> Types.None + +type rTLabs_pc = +| Rapc_state of Pointers.block * Graphs.label +| Rapc_call of Graphs.label Types.option * Pointers.block +| Rapc_ret of Pointers.block Types.option +| Rapc_fin + +(** val rTLabs_pc_rect_Type4 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 **) +let rec rTLabs_pc_rect_Type4 h_rapc_state h_rapc_call h_rapc_ret h_rapc_fin = function +| Rapc_state (x_24356, x_24355) -> h_rapc_state x_24356 x_24355 +| Rapc_call (x_24358, x_24357) -> h_rapc_call x_24358 x_24357 +| Rapc_ret x_24359 -> h_rapc_ret x_24359 +| Rapc_fin -> h_rapc_fin + +(** val rTLabs_pc_rect_Type5 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 **) +let rec rTLabs_pc_rect_Type5 h_rapc_state h_rapc_call h_rapc_ret h_rapc_fin = function +| Rapc_state (x_24366, x_24365) -> h_rapc_state x_24366 x_24365 +| Rapc_call (x_24368, x_24367) -> h_rapc_call x_24368 x_24367 +| Rapc_ret x_24369 -> h_rapc_ret x_24369 +| Rapc_fin -> h_rapc_fin + +(** val rTLabs_pc_rect_Type3 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 **) +let rec rTLabs_pc_rect_Type3 h_rapc_state h_rapc_call h_rapc_ret h_rapc_fin = function +| Rapc_state (x_24376, x_24375) -> h_rapc_state x_24376 x_24375 +| Rapc_call (x_24378, x_24377) -> h_rapc_call x_24378 x_24377 +| Rapc_ret x_24379 -> h_rapc_ret x_24379 +| Rapc_fin -> h_rapc_fin + +(** val rTLabs_pc_rect_Type2 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 **) +let rec rTLabs_pc_rect_Type2 h_rapc_state h_rapc_call h_rapc_ret h_rapc_fin = function +| Rapc_state (x_24386, x_24385) -> h_rapc_state x_24386 x_24385 +| Rapc_call (x_24388, x_24387) -> h_rapc_call x_24388 x_24387 +| Rapc_ret x_24389 -> h_rapc_ret x_24389 +| Rapc_fin -> h_rapc_fin + +(** val rTLabs_pc_rect_Type1 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 **) +let rec rTLabs_pc_rect_Type1 h_rapc_state h_rapc_call h_rapc_ret h_rapc_fin = function +| Rapc_state (x_24396, x_24395) -> h_rapc_state x_24396 x_24395 +| Rapc_call (x_24398, x_24397) -> h_rapc_call x_24398 x_24397 +| Rapc_ret x_24399 -> h_rapc_ret x_24399 +| Rapc_fin -> h_rapc_fin + +(** val rTLabs_pc_rect_Type0 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 **) +let rec rTLabs_pc_rect_Type0 h_rapc_state h_rapc_call h_rapc_ret h_rapc_fin = function +| Rapc_state (x_24406, x_24405) -> h_rapc_state x_24406 x_24405 +| Rapc_call (x_24408, x_24407) -> h_rapc_call x_24408 x_24407 +| Rapc_ret x_24409 -> h_rapc_ret x_24409 +| Rapc_fin -> h_rapc_fin + +(** val rTLabs_pc_inv_rect_Type4 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> + (Graphs.label Types.option -> Pointers.block -> __ -> 'a1) -> + (Pointers.block Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let rTLabs_pc_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = rTLabs_pc_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val rTLabs_pc_inv_rect_Type3 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> + (Graphs.label Types.option -> Pointers.block -> __ -> 'a1) -> + (Pointers.block Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let rTLabs_pc_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = rTLabs_pc_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val rTLabs_pc_inv_rect_Type2 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> + (Graphs.label Types.option -> Pointers.block -> __ -> 'a1) -> + (Pointers.block Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let rTLabs_pc_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = rTLabs_pc_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val rTLabs_pc_inv_rect_Type1 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> + (Graphs.label Types.option -> Pointers.block -> __ -> 'a1) -> + (Pointers.block Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let rTLabs_pc_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = rTLabs_pc_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val rTLabs_pc_inv_rect_Type0 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> + (Graphs.label Types.option -> Pointers.block -> __ -> 'a1) -> + (Pointers.block Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let rTLabs_pc_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = rTLabs_pc_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val rTLabs_pc_discr : rTLabs_pc -> rTLabs_pc -> __ **) +let rTLabs_pc_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Rapc_state (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Rapc_call (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Rapc_ret a0 -> Obj.magic (fun _ dH -> dH __) + | Rapc_fin -> Obj.magic (fun _ dH -> dH)) y + +(** val rTLabs_pc_jmdiscr : rTLabs_pc -> rTLabs_pc -> __ **) +let rTLabs_pc_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Rapc_state (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Rapc_call (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Rapc_ret a0 -> Obj.magic (fun _ dH -> dH __) + | Rapc_fin -> Obj.magic (fun _ dH -> dH)) y + +(** val rTLabs_pc_eq : rTLabs_pc -> rTLabs_pc -> Bool.bool **) +let rTLabs_pc_eq x y = + match x with + | Rapc_state (b1, l1) -> + (match y with + | Rapc_state (b2, l2) -> + Bool.andb (Pointers.eq_block b1 b2) + (Identifiers.eq_identifier PreIdentifiers.LabelTag l1 l2) + | Rapc_call (x0, x1) -> Bool.False + | Rapc_ret x0 -> Bool.False + | Rapc_fin -> Bool.False) + | Rapc_call (o1, b1) -> + (match y with + | Rapc_state (x0, x1) -> Bool.False + | Rapc_call (o2, b2) -> + Bool.andb + (Deqsets.eqb + (Deqsets.deqOption + (Identifiers.deq_identifier PreIdentifiers.LabelTag)) + (Obj.magic o1) (Obj.magic o2)) (Pointers.eq_block b1 b2) + | Rapc_ret x0 -> Bool.False + | Rapc_fin -> Bool.False) + | Rapc_ret b1 -> + (match y with + | Rapc_state (x0, x1) -> Bool.False + | Rapc_call (x0, x1) -> Bool.False + | Rapc_ret b2 -> + Deqsets.eqb (Deqsets.deqOption Pointers.block_eq) (Obj.magic b1) + (Obj.magic b2) + | Rapc_fin -> Bool.False) + | Rapc_fin -> + (match y with + | Rapc_state (x0, x1) -> Bool.False + | Rapc_call (x0, x1) -> Bool.False + | Rapc_ret x0 -> Bool.False + | Rapc_fin -> Bool.True) + +(** val rTLabs_deqset : Deqsets.deqSet **) +let rTLabs_deqset = + Obj.magic rTLabs_pc_eq + +(** val rTLabs_ext_state_to_pc : + RTLabs_semantics.genv -> rTLabs_ext_state -> __ **) +let rTLabs_ext_state_to_pc ge s = + let { ras_state = s'; ras_fn_stack = stk } = s in + (match s' with + | RTLabs_semantics.State (f, fs, m) -> + (match stk with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (b, x) -> + (fun _ -> Obj.magic (Rapc_state (b, f.RTLabs_semantics.next)))) + | RTLabs_semantics.Callstate (x, x0, x1, x2, fs, x3) -> + (match stk with + | List.Nil -> (fun _ _ -> assert false (* absurd case *)) + | List.Cons (b, x4) -> + (fun _ _ -> + Obj.magic (Rapc_call + ((match fs with + | List.Nil -> Types.None + | List.Cons (f, x6) -> Types.Some f.RTLabs_semantics.next), b)))) + __ + | RTLabs_semantics.Returnstate (x, x0, x1, x2) -> + (match stk with + | List.Nil -> (fun _ -> Obj.magic (Rapc_ret Types.None)) + | List.Cons (b, x3) -> (fun _ -> Obj.magic (Rapc_ret (Types.Some b)))) + | RTLabs_semantics.Finalstate x -> (fun _ -> Obj.magic Rapc_fin)) __ + +(** val rTLabs_pc_to_cost_label : + RTLabs_syntax.internal_function AST.fundef Globalenvs.genv_t -> rTLabs_pc + -> CostLabel.costlabel Types.option **) +let rTLabs_pc_to_cost_label ge = function +| Rapc_state (b, l) -> + (match Globalenvs.find_funct_ptr ge b with + | Types.None -> Types.None + | Types.Some fd -> + (match fd with + | AST.Internal f -> + (match Identifiers.lookup PreIdentifiers.LabelTag + f.RTLabs_syntax.f_graph l with + | Types.None -> Types.None + | Types.Some s -> CostSpec.cost_label_of s) + | AST.External x -> Types.None)) +| Rapc_call (x, x0) -> Types.None +| Rapc_ret x -> Types.None +| Rapc_fin -> Types.None + +(** val rTLabs_call_ident : + RTLabs_semantics.genv -> rTLabs_ext_state Types.sig0 -> AST.ident **) +let rTLabs_call_ident ge s = + let s0 = s in + (let { ras_state = s'; ras_fn_stack = stk } = s0 in + (match s' with + | RTLabs_semantics.State (f, x, x0) -> + (fun _ -> assert false (* absurd case *)) + | RTLabs_semantics.Callstate (fid, x, x0, x1, x2, x3) -> (fun _ -> fid) + | RTLabs_semantics.Returnstate (x, x0, x1, x2) -> + (fun _ -> assert false (* absurd case *)) + | RTLabs_semantics.Finalstate x -> + (fun _ -> assert false (* absurd case *)))) __ + +(** val rTLabs_status : + RTLabs_semantics.genv -> StructuredTraces.abstract_status **) +let rTLabs_status ge = + { StructuredTraces.as_pc = rTLabs_deqset; StructuredTraces.as_pc_of = + (Obj.magic (rTLabs_ext_state_to_pc ge)); StructuredTraces.as_classify = + (fun h -> rTLabs_classify (Obj.magic h).ras_state); + StructuredTraces.as_label_of_pc = + (Obj.magic (rTLabs_pc_to_cost_label ge)); StructuredTraces.as_result = + (fun h -> RTLabs_semantics.rTLabs_is_final (Obj.magic h).ras_state); + StructuredTraces.as_call_ident = (Obj.magic (rTLabs_call_ident ge)); + StructuredTraces.as_tailcall_ident = (fun s -> assert false + (* absurd case *)) } + +(** val eval_ext_statement : + RTLabs_semantics.genv -> rTLabs_ext_state -> (IO.io_out, IO.io_in, + (Events.trace, rTLabs_ext_state) Types.prod) IOMonad.iO **) +let eval_ext_statement ge s = + (match RTLabs_semantics.eval_statement ge s.ras_state with + | IOMonad.Interact (o, k) -> + (fun x -> IOMonad.Wrong (Errors.msg ErrorMessages.UnexpectedIO)) + | IOMonad.Value ts -> + (fun next -> IOMonad.Value { Types.fst = ts.Types.fst; Types.snd = + (next ts.Types.snd ts.Types.fst __) }) + | IOMonad.Wrong m -> (fun x -> IOMonad.Wrong m)) (fun x x0 _ -> + next_state ge s x x0) + +(** val rTLabs_ext_exec : + (IO.io_out, IO.io_in) SmallstepExec.trans_system **) +let rTLabs_ext_exec = + { SmallstepExec.is_final = (fun x h -> + RTLabs_semantics.rTLabs_is_final (Obj.magic h).ras_state); + SmallstepExec.step = (Obj.magic eval_ext_statement) } + +(** val make_ext_initial_state : + RTLabs_syntax.rTLabs_program -> rTLabs_ext_state Errors.res **) +let make_ext_initial_state p = + let ge = RTLabs_semantics.make_global p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Globalenvs.init_mem (fun x -> x) p)) (fun m -> + let main = p.AST.prog_main in + Obj.magic + (Errors.bind_eq + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingSymbol), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, main)), List.Nil)))) + (Globalenvs.find_symbol ge main)) (fun b _ -> + Errors.bind_eq + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, main)), List.Nil)))) + (Globalenvs.find_funct_ptr ge b)) (fun f _ -> + let s = RTLabs_semantics.Callstate (main, f, List.Nil, + Types.None, List.Nil, m) + in + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { ras_state = s; + ras_fn_stack = (List.Cons (b, List.Nil)) })))))) + +(** val rTLabs_ext_fullexec : + (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let rTLabs_ext_fullexec = + { SmallstepExec.es1 = rTLabs_ext_exec; SmallstepExec.make_global = + (Obj.magic RTLabs_semantics.make_global); + SmallstepExec.make_initial_state = (Obj.magic make_ext_initial_state) } + diff --git a/extracted/rTLabs_abstract.mli b/extracted/rTLabs_abstract.mli new file mode 100644 index 0000000..5c2ca88 --- /dev/null +++ b/extracted/rTLabs_abstract.mli @@ -0,0 +1,318 @@ +open Preamble + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +open SmallstepExec + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open RTLabs_semantics + +type rTLabs_state = RTLabs_semantics.state + +type rTLabs_genv = RTLabs_semantics.genv + +open Sets + +open Listb + +open StructuredTraces + +open CostSpec + +open Deqsets_extra + +val status_class_jmdiscr : + StructuredTraces.status_class -> StructuredTraces.status_class -> __ + +type rTLabs_ext_state = { ras_state : RTLabs_semantics.state; + ras_fn_stack : Pointers.block List.list } + +val rTLabs_ext_state_rect_Type4 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 + +val rTLabs_ext_state_rect_Type5 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 + +val rTLabs_ext_state_rect_Type3 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 + +val rTLabs_ext_state_rect_Type2 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 + +val rTLabs_ext_state_rect_Type1 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 + +val rTLabs_ext_state_rect_Type0 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Pointers.block + List.list -> __ -> 'a1) -> rTLabs_ext_state -> 'a1 + +val ras_state : + RTLabs_semantics.genv -> rTLabs_ext_state -> RTLabs_semantics.state + +val ras_fn_stack : + RTLabs_semantics.genv -> rTLabs_ext_state -> Pointers.block List.list + +val rTLabs_ext_state_inv_rect_Type4 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 + +val rTLabs_ext_state_inv_rect_Type3 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 + +val rTLabs_ext_state_inv_rect_Type2 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 + +val rTLabs_ext_state_inv_rect_Type1 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 + +val rTLabs_ext_state_inv_rect_Type0 : + RTLabs_semantics.genv -> rTLabs_ext_state -> (RTLabs_semantics.state -> + Pointers.block List.list -> __ -> __ -> 'a1) -> 'a1 + +val rTLabs_ext_state_discr : + RTLabs_semantics.genv -> rTLabs_ext_state -> rTLabs_ext_state -> __ + +val rTLabs_ext_state_jmdiscr : + RTLabs_semantics.genv -> rTLabs_ext_state -> rTLabs_ext_state -> __ + +val dpi1__o__Ras_state__o__inject : + RTLabs_semantics.genv -> (rTLabs_ext_state, 'a1) Types.dPair -> + RTLabs_semantics.state Types.sig0 + +val eject__o__Ras_state__o__inject : + RTLabs_semantics.genv -> rTLabs_ext_state Types.sig0 -> + RTLabs_semantics.state Types.sig0 + +val ras_state__o__inject : + RTLabs_semantics.genv -> rTLabs_ext_state -> RTLabs_semantics.state + Types.sig0 + +val dpi1__o__Ras_state : + RTLabs_semantics.genv -> (rTLabs_ext_state, 'a1) Types.dPair -> + RTLabs_semantics.state + +val eject__o__Ras_state : + RTLabs_semantics.genv -> rTLabs_ext_state Types.sig0 -> + RTLabs_semantics.state + +val next_state : + RTLabs_semantics.genv -> rTLabs_ext_state -> RTLabs_semantics.state -> + Events.trace -> rTLabs_ext_state + +val rTLabs_classify : RTLabs_semantics.state -> StructuredTraces.status_class + +val rTLabs_cost : RTLabs_semantics.state -> Bool.bool + +val rTLabs_cost_label : + RTLabs_semantics.state -> CostLabel.costlabel Types.option + +type rTLabs_pc = +| Rapc_state of Pointers.block * Graphs.label +| Rapc_call of Graphs.label Types.option * Pointers.block +| Rapc_ret of Pointers.block Types.option +| Rapc_fin + +val rTLabs_pc_rect_Type4 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 + +val rTLabs_pc_rect_Type5 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 + +val rTLabs_pc_rect_Type3 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 + +val rTLabs_pc_rect_Type2 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 + +val rTLabs_pc_rect_Type1 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 + +val rTLabs_pc_rect_Type0 : + (Pointers.block -> Graphs.label -> 'a1) -> (Graphs.label Types.option -> + Pointers.block -> 'a1) -> (Pointers.block Types.option -> 'a1) -> 'a1 -> + rTLabs_pc -> 'a1 + +val rTLabs_pc_inv_rect_Type4 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> (Graphs.label + Types.option -> Pointers.block -> __ -> 'a1) -> (Pointers.block + Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val rTLabs_pc_inv_rect_Type3 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> (Graphs.label + Types.option -> Pointers.block -> __ -> 'a1) -> (Pointers.block + Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val rTLabs_pc_inv_rect_Type2 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> (Graphs.label + Types.option -> Pointers.block -> __ -> 'a1) -> (Pointers.block + Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val rTLabs_pc_inv_rect_Type1 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> (Graphs.label + Types.option -> Pointers.block -> __ -> 'a1) -> (Pointers.block + Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val rTLabs_pc_inv_rect_Type0 : + rTLabs_pc -> (Pointers.block -> Graphs.label -> __ -> 'a1) -> (Graphs.label + Types.option -> Pointers.block -> __ -> 'a1) -> (Pointers.block + Types.option -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val rTLabs_pc_discr : rTLabs_pc -> rTLabs_pc -> __ + +val rTLabs_pc_jmdiscr : rTLabs_pc -> rTLabs_pc -> __ + +val rTLabs_pc_eq : rTLabs_pc -> rTLabs_pc -> Bool.bool + +val rTLabs_deqset : Deqsets.deqSet + +val rTLabs_ext_state_to_pc : RTLabs_semantics.genv -> rTLabs_ext_state -> __ + +val rTLabs_pc_to_cost_label : + RTLabs_syntax.internal_function AST.fundef Globalenvs.genv_t -> rTLabs_pc + -> CostLabel.costlabel Types.option + +val rTLabs_call_ident : + RTLabs_semantics.genv -> rTLabs_ext_state Types.sig0 -> AST.ident + +val rTLabs_status : RTLabs_semantics.genv -> StructuredTraces.abstract_status + +val eval_ext_statement : + RTLabs_semantics.genv -> rTLabs_ext_state -> (IO.io_out, IO.io_in, + (Events.trace, rTLabs_ext_state) Types.prod) IOMonad.iO + +val rTLabs_ext_exec : (IO.io_out, IO.io_in) SmallstepExec.trans_system + +val make_ext_initial_state : + RTLabs_syntax.rTLabs_program -> rTLabs_ext_state Errors.res + +val rTLabs_ext_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec + diff --git a/extracted/rTLabs_classified_system.ml b/extracted/rTLabs_classified_system.ml new file mode 100644 index 0000000..7fc8ee8 --- /dev/null +++ b/extracted/rTLabs_classified_system.ml @@ -0,0 +1,169 @@ +open Preamble + +open Deqsets_extra + +open CostSpec + +open Sets + +open Listb + +open StructuredTraces + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +open SmallstepExec + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open RTLabs_semantics + +open RTLabs_abstract + +open Stacksize + +open Executions + +open Measurable + +(** val rTLabs_stack_ident : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_state -> AST.ident **) +let rTLabs_stack_ident ge s = + (match s with + | RTLabs_semantics.State (x, x0, x1) -> + (fun _ -> assert false (* absurd case *)) + | RTLabs_semantics.Callstate (id, x, x0, x1, x2, x3) -> (fun _ -> id) + | RTLabs_semantics.Returnstate (x, x0, x1, x2) -> + (fun _ -> assert false (* absurd case *)) + | RTLabs_semantics.Finalstate x -> + (fun _ -> assert false (* absurd case *))) __ + +(** val rTLabs_pcs : Measurable.preclassified_system **) +let rTLabs_pcs = + { Measurable.pcs_exec = RTLabs_semantics.rTLabs_fullexec; + Measurable.pcs_labelled = (fun x -> + Obj.magic RTLabs_abstract.rTLabs_cost); Measurable.pcs_classify = + (fun x -> Obj.magic RTLabs_abstract.rTLabs_classify); + Measurable.pcs_callee = + (Obj.magic (fun x x0 _ -> rTLabs_stack_ident x x0)) } + +(** val rTLabs_ext_pcs : Measurable.preclassified_system **) +let rTLabs_ext_pcs = + { Measurable.pcs_exec = RTLabs_abstract.rTLabs_ext_fullexec; + Measurable.pcs_labelled = (fun g s -> + RTLabs_abstract.rTLabs_cost (Obj.magic s).RTLabs_abstract.ras_state); + Measurable.pcs_classify = (fun g s -> + RTLabs_abstract.rTLabs_classify (Obj.magic s).RTLabs_abstract.ras_state); + Measurable.pcs_callee = (fun g s _ -> + rTLabs_stack_ident (Obj.magic g) (Obj.magic s).RTLabs_abstract.ras_state) } + diff --git a/extracted/rTLabs_classified_system.mli b/extracted/rTLabs_classified_system.mli new file mode 100644 index 0000000..42f2876 --- /dev/null +++ b/extracted/rTLabs_classified_system.mli @@ -0,0 +1,145 @@ +open Preamble + +open Deqsets_extra + +open CostSpec + +open Sets + +open Listb + +open StructuredTraces + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +open SmallstepExec + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open RTLabs_semantics + +open RTLabs_abstract + +open Stacksize + +open Executions + +open Measurable + +val rTLabs_stack_ident : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_state -> AST.ident + +val rTLabs_pcs : Measurable.preclassified_system + +val rTLabs_ext_pcs : Measurable.preclassified_system + diff --git a/extracted/rTLabs_semantics.ml b/extracted/rTLabs_semantics.ml new file mode 100644 index 0000000..f089e6e --- /dev/null +++ b/extracted/rTLabs_semantics.ml @@ -0,0 +1,1711 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open CostLabel + +open Events + +open IOMonad + +open IO + +open SmallstepExec + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +type genv = RTLabs_syntax.internal_function AST.fundef Globalenvs.genv_t + +type frame = { func : RTLabs_syntax.internal_function; + locals : Values.val0 Registers.register_env; + next : Graphs.label; sp : Pointers.block; + retdst : Registers.register Types.option } + +(** val frame_rect_Type4 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option + -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type4 h_mk_frame x_23982 = + let { func = func0; locals = locals0; next = next0; sp = sp0; retdst = + retdst0 } = x_23982 + in + h_mk_frame func0 locals0 next0 __ sp0 retdst0 + +(** val frame_rect_Type5 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option + -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type5 h_mk_frame x_23984 = + let { func = func0; locals = locals0; next = next0; sp = sp0; retdst = + retdst0 } = x_23984 + in + h_mk_frame func0 locals0 next0 __ sp0 retdst0 + +(** val frame_rect_Type3 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option + -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type3 h_mk_frame x_23986 = + let { func = func0; locals = locals0; next = next0; sp = sp0; retdst = + retdst0 } = x_23986 + in + h_mk_frame func0 locals0 next0 __ sp0 retdst0 + +(** val frame_rect_Type2 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option + -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type2 h_mk_frame x_23988 = + let { func = func0; locals = locals0; next = next0; sp = sp0; retdst = + retdst0 } = x_23988 + in + h_mk_frame func0 locals0 next0 __ sp0 retdst0 + +(** val frame_rect_Type1 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option + -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type1 h_mk_frame x_23990 = + let { func = func0; locals = locals0; next = next0; sp = sp0; retdst = + retdst0 } = x_23990 + in + h_mk_frame func0 locals0 next0 __ sp0 retdst0 + +(** val frame_rect_Type0 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option + -> 'a1) -> frame -> 'a1 **) +let rec frame_rect_Type0 h_mk_frame x_23992 = + let { func = func0; locals = locals0; next = next0; sp = sp0; retdst = + retdst0 } = x_23992 + in + h_mk_frame func0 locals0 next0 __ sp0 retdst0 + +(** val func : frame -> RTLabs_syntax.internal_function **) +let rec func xxx = + xxx.func + +(** val locals : frame -> Values.val0 Registers.register_env **) +let rec locals xxx = + xxx.locals + +(** val next : frame -> Graphs.label **) +let rec next xxx = + xxx.next + +(** val sp : frame -> Pointers.block **) +let rec sp xxx = + xxx.sp + +(** val retdst : frame -> Registers.register Types.option **) +let rec retdst xxx = + xxx.retdst + +(** val frame_inv_rect_Type4 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type4 hterm h1 = + let hcut = frame_rect_Type4 h1 hterm in hcut __ + +(** val frame_inv_rect_Type3 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type3 hterm h1 = + let hcut = frame_rect_Type3 h1 hterm in hcut __ + +(** val frame_inv_rect_Type2 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type2 hterm h1 = + let hcut = frame_rect_Type2 h1 hterm in hcut __ + +(** val frame_inv_rect_Type1 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type1 hterm h1 = + let hcut = frame_rect_Type1 h1 hterm in hcut __ + +(** val frame_inv_rect_Type0 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 **) +let frame_inv_rect_Type0 hterm h1 = + let hcut = frame_rect_Type0 h1 hterm in hcut __ + +(** val frame_jmdiscr : frame -> frame -> __ **) +let frame_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { func = a0; locals = a1; next = a2; sp = a4; retdst = a5 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val adv : Graphs.label -> frame -> frame **) +let adv l f = + { func = f.func; locals = f.locals; next = l; sp = f.sp; retdst = + f.retdst } + +type state = +| State of frame * frame List.list * GenMem.mem +| Callstate of AST.ident * RTLabs_syntax.internal_function AST.fundef + * Values.val0 List.list * Registers.register Types.option + * frame List.list * GenMem.mem +| Returnstate of Values.val0 Types.option * Registers.register Types.option + * frame List.list * GenMem.mem +| Finalstate of Integers.int + +(** val state_rect_Type4 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) + -> (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type4 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, fs, m) -> h_State f fs m +| Callstate (id, fd, args, dst, stk, m) -> h_Callstate id fd args dst stk m +| Returnstate (rtv, dst, stk, m) -> h_Returnstate rtv dst stk m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type5 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) + -> (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type5 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, fs, m) -> h_State f fs m +| Callstate (id, fd, args, dst, stk, m) -> h_Callstate id fd args dst stk m +| Returnstate (rtv, dst, stk, m) -> h_Returnstate rtv dst stk m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type3 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) + -> (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type3 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, fs, m) -> h_State f fs m +| Callstate (id, fd, args, dst, stk, m) -> h_Callstate id fd args dst stk m +| Returnstate (rtv, dst, stk, m) -> h_Returnstate rtv dst stk m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type2 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) + -> (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type2 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, fs, m) -> h_State f fs m +| Callstate (id, fd, args, dst, stk, m) -> h_Callstate id fd args dst stk m +| Returnstate (rtv, dst, stk, m) -> h_Returnstate rtv dst stk m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type1 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) + -> (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type1 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, fs, m) -> h_State f fs m +| Callstate (id, fd, args, dst, stk, m) -> h_Callstate id fd args dst stk m +| Returnstate (rtv, dst, stk, m) -> h_Returnstate rtv dst stk m +| Finalstate r -> h_Finalstate r + +(** val state_rect_Type0 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) + -> (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 **) +let rec state_rect_Type0 h_State h_Callstate h_Returnstate h_Finalstate = function +| State (f, fs, m) -> h_State f fs m +| Callstate (id, fd, args, dst, stk, m) -> h_Callstate id fd args dst stk m +| Returnstate (rtv, dst, stk, m) -> h_Returnstate rtv dst stk m +| Finalstate r -> h_Finalstate r + +(** val state_inv_rect_Type4 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> __ -> + 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type3 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> __ -> + 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type2 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> __ -> + 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type1 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> __ -> + 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val state_inv_rect_Type0 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> __ -> + 'a1) -> (Integers.int -> __ -> 'a1) -> 'a1 **) +let state_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = state_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val state_jmdiscr : state -> state -> __ **) +let state_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | State (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | Callstate (a0, a1, a2, a3, a4, a5) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __) + | Returnstate (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Finalstate a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val build_state : + frame -> frame List.list -> GenMem.mem -> Graphs.label -> state **) +let build_state f fs m n = + State ((adv n f), fs, m) + +(** val next_instruction : frame -> RTLabs_syntax.statement **) +let next_instruction f = + Identifiers.lookup_present PreIdentifiers.LabelTag + f.func.RTLabs_syntax.f_graph f.next + +(** val init_locals : + (Registers.register, AST.typ) Types.prod List.list -> Values.val0 + Registers.register_env **) +let init_locals = + List.foldr (fun idt en -> + let { Types.fst = id; Types.snd = ty } = idt in + Identifiers.add PreIdentifiers.RegisterTag en id Values.Vundef) + (Identifiers.empty_map PreIdentifiers.RegisterTag) + +(** val reg_store : + PreIdentifiers.identifier -> Values.val0 -> Values.val0 + Identifiers.identifier_map -> Values.val0 Identifiers.identifier_map + Errors.res **) +let reg_store reg v locals0 = + Identifiers.update PreIdentifiers.RegisterTag locals0 reg v + +(** val params_store : + (Registers.register, AST.typ) Types.prod List.list -> Values.val0 + List.list -> Values.val0 Registers.register_env -> Values.val0 + Registers.register_env Errors.res **) +let rec params_store rs vs locals0 = + match rs with + | List.Nil -> + (match vs with + | List.Nil -> Errors.OK locals0 + | List.Cons (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.WrongNumberOfParameters)) + | List.Cons (rt, rst) -> + (match vs with + | List.Nil -> + Errors.Error (Errors.msg ErrorMessages.WrongNumberOfParameters) + | List.Cons (v, vst) -> + let { Types.fst = r; Types.snd = ty } = rt in + let locals' = Identifiers.add PreIdentifiers.RegisterTag locals0 r v + in + params_store rst vst locals') + +(** val reg_retrieve : + Values.val0 Registers.register_env -> Registers.register -> Values.val0 + Errors.res **) +let reg_retrieve locals0 reg = + Errors.opt_to_res (List.Cons ((Errors.MSG ErrorMessages.BadRegister), + (List.Cons ((Errors.CTX (PreIdentifiers.RegisterTag, reg)), List.Nil)))) + (Identifiers.lookup PreIdentifiers.RegisterTag locals0 reg) + +(** val eval_statement : + genv -> state -> (IO.io_out, IO.io_in, (Events.trace, state) Types.prod) + IOMonad.iO **) +let eval_statement ge = function +| State (f, fs, m) -> + let s = next_instruction f in + (match s with + | RTLabs_syntax.St_skip l -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { Types.fst = + Events.e0; Types.snd = (build_state f fs m l) })) + | RTLabs_syntax.St_cost (cl, l) -> + (fun _ -> + Obj.magic + (Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { Types.fst = + (Events.echarge cl); Types.snd = (build_state f fs m l) })) + | RTLabs_syntax.St_const (x, r, cst, l) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedConstant) + (FrontEndOps.eval_constant x (Globalenvs.find_symbol ge) + f.sp cst))) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r v f.locals)) (fun locals0 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = + locals0; next = l; sp = f.sp; retdst = f.retdst }, fs, m)) }))))) + | RTLabs_syntax.St_op1 (x, x0, op, dst, src, l) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals src)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_unop x0 x op v))) (fun v' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store dst v' f.locals)) (fun locals0 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = + locals0; next = l; sp = f.sp; retdst = f.retdst }, fs, + m)) })))))) + | RTLabs_syntax.St_op2 (x, x0, x1, op, dst, src1, src2, l) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals src1)) (fun v1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals src2)) (fun v2 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_binop m x0 x1 x op v1 v2))) (fun v' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store dst v' f.locals)) (fun locals0 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = + locals0; next = l; sp = f.sp; retdst = f.retdst }, fs, + m)) }))))))) + | RTLabs_syntax.St_load (chunk, addr, dst, l) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals addr)) (fun vaddr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (FrontEndMem.loadv chunk m vaddr))) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store dst v f.locals)) (fun locals0 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = + locals0; next = l; sp = f.sp; retdst = f.retdst }, fs, + m)) })))))) + | RTLabs_syntax.St_store (chunk, addr, src, l) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals addr)) (fun vaddr -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals src)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedStore) + (FrontEndMem.storev chunk m vaddr v))) (fun m' -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (build_state f fs m' l) })))))) + | RTLabs_syntax.St_call_id (id, args, dst, l) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingSymbol), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Globalenvs.find_symbol ge id))) (fun b -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Globalenvs.find_funct_ptr ge b))) (fun fd -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals)) args) (fun vs -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (id, fd, vs, dst, + (List.Cons ((adv l f), fs)), m)) })))))) + | RTLabs_syntax.St_call_ptr (frs, args, dst, l) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals frs)) (fun fv -> + Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.BadFunction) + (Globalenvs.find_funct_id ge fv))) (fun fd id -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals)) args) (fun vs -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (id, fd, vs, dst, + (List.Cons ((adv l f), fs)), m)) })))))) + | RTLabs_syntax.St_cond (src, ltrue, lfalse) -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals src)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Values.eval_bool_of_val v)) (fun b -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state f fs m + (match b with + | Bool.True -> ltrue + | Bool.False -> lfalse)) }))))) + | RTLabs_syntax.St_return -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (match f.func.RTLabs_syntax.f_result with + | Types.None -> + Monad.m_return0 (Monad.max_def Errors.res0) Types.None + | Types.Some rt -> + let { Types.fst = r; Types.snd = ty } = rt in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve f.locals r)) (fun v -> + Monad.m_return0 (Monad.max_def Errors.res0) (Types.Some v))) + (fun v -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Returnstate (v, f.retdst, fs, + (GenMem.free m f.sp))) }))))) __ +| Callstate (x, fd, params, dst, fs, m) -> + (match fd with + | AST.Internal fn -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (params_store fn.RTLabs_syntax.f_params params + (init_locals fn.RTLabs_syntax.f_locals))) (fun locals0 -> + let { Types.fst = m'; Types.snd = sp0 } = + GenMem.alloc m (Z.z_of_nat Nat.O) + (Z.z_of_nat fn.RTLabs_syntax.f_stacksize) + in + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = fn; locals = locals0; + next = (Types.pi1 fn.RTLabs_syntax.f_entry); sp = sp0; retdst = + dst }, fs, m')) }))) + | AST.External fn -> + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IOMonad.err_to_io + (IO.check_eventval_list params fn.AST.ef_sig.AST.sig_args))) + (fun evargs -> + Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IO.do_io fn.AST.ef_id evargs (AST.proj_sig_res fn.AST.ef_sig))) + (fun evres -> + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { Types.fst = + (Events.eextcall fn.AST.ef_id evargs + (IO.mk_eventval (AST.proj_sig_res fn.AST.ef_sig) evres)); + Types.snd = (Returnstate ((Types.Some + (IO.mk_val (AST.proj_sig_res fn.AST.ef_sig) evres)), dst, fs, + m)) })))) +| Returnstate (v, dst, fs, m) -> + (match fs with + | List.Nil -> + (fun _ -> + (match v with + | Types.None -> + (fun _ -> + IOMonad.err_to_io (Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch))) + | Types.Some v' -> + (fun _ -> + (match v' with + | Values.Vundef -> + (fun _ -> + IOMonad.err_to_io (Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch))) + | Values.Vint (sz, r) -> + (fun _ -> + IOMonad.err_to_io + ((match sz with + | AST.I8 -> + (fun x -> Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch)) + | AST.I16 -> + (fun x -> Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch)) + | AST.I32 -> + (fun r0 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + { Types.fst = Events.e0; Types.snd = (Finalstate + r0) }))) r)) + | Values.Vnull -> + (fun _ -> + IOMonad.err_to_io (Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch))) + | Values.Vptr x -> + (fun _ -> + IOMonad.err_to_io (Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch)))) __)) __) + | List.Cons (f, fs') -> + (fun _ -> + IOMonad.err_to_io + (Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (match dst with + | Types.None -> + (match v with + | Types.None -> Obj.magic (Errors.OK f.locals) + | Types.Some x -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch))) + | Types.Some d -> + (match v with + | Types.None -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.ReturnMismatch)) + | Types.Some v' -> Obj.magic (reg_store d v' f.locals))) + (fun locals0 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = + locals0; next = f.next; sp = f.sp; retdst = f.retdst }, fs', + m)) }))))) __ +| Finalstate r -> + IOMonad.err_to_io (Errors.Error (Errors.msg ErrorMessages.FinalState)) + +(** val rTLabs_is_final : state -> Integers.int Types.option **) +let rTLabs_is_final = function +| State (x, x0, x1) -> Types.None +| Callstate (x, x0, x1, x2, x3, x4) -> Types.None +| Returnstate (x, x0, x1, x2) -> Types.None +| Finalstate r -> Types.Some r + +(** val rTLabs_exec : (IO.io_out, IO.io_in) SmallstepExec.trans_system **) +let rTLabs_exec = + { SmallstepExec.is_final = (fun x -> Obj.magic rTLabs_is_final); + SmallstepExec.step = (Obj.magic eval_statement) } + +(** val make_global : RTLabs_syntax.rTLabs_program -> genv **) +let make_global p = + Globalenvs.globalenv (fun x -> x) p + +(** val make_initial_state : + RTLabs_syntax.rTLabs_program -> state Errors.res **) +let make_initial_state p = + let ge = make_global p in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Globalenvs.init_mem (fun x -> x) p)) (fun m -> + let main = p.AST.prog_main in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingSymbol), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, main)), List.Nil)))) + (Globalenvs.find_symbol ge main))) (fun b -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, main)), List.Nil)))) + (Globalenvs.find_funct_ptr ge b))) (fun f -> + Obj.magic (Errors.OK (Callstate (main, f, List.Nil, Types.None, + List.Nil, m))))))) + +(** val rTLabs_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec **) +let rTLabs_fullexec = + { SmallstepExec.es1 = rTLabs_exec; SmallstepExec.make_global = + (Obj.magic make_global); SmallstepExec.make_initial_state = + (Obj.magic make_initial_state) } + +(** val bind_ok : + 'a1 Errors.res -> ('a1 -> 'a2 Errors.res) -> 'a2 -> ('a1 -> __ -> __ -> + 'a3) -> 'a3 **) +let bind_ok clearme f v x = + (match clearme with + | Errors.OK a -> (fun f0 v0 _ h _ -> h a __ __) + | Errors.Error m -> + (fun f0 v0 _ h _ -> + Obj.magic Errors.res_discr (Errors.Error m) (Errors.OK v0) __)) f v __ + x __ + +(** val jmeq_hackT : 'a1 -> 'a1 -> (__ -> 'a2) -> 'a2 **) +let jmeq_hackT x y auto = + auto __ + +(** val func_block_of_exec : + genv -> state -> Events.trace -> AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> + Pointers.block Types.sig0 **) +let func_block_of_exec ge clearme t fid fd args dst fs m = + (match clearme with + | State (clearme0, x, x0) -> + (let { func = func0; locals = locals0; next = next0; sp = sp0; retdst = + dst0 } = clearme0 + in + (fun fs0 m0 tr fid0 fd0 args0 dst' fs' m' -> + (match next_instruction { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 } with + | RTLabs_syntax.St_skip l -> + (fun _ _ -> + jmeq_hackT (IOMonad.Value { Types.fst = Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = next0; sp = + sp0; retdst = dst0 } fs0 m0 l) }) (IOMonad.Value { Types.fst = + tr; Types.snd = (Callstate (fid0, fd0, args0, dst', fs', m')) }) + (fun _ -> + Obj.magic IOMonad.iO_jmdiscr (IOMonad.Value { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 } fs0 m0 l) }) (IOMonad.Value + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = Events.e0; + Types.snd = + (build_state { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 } fs0 m0 l) } { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', m')) } + __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0, m0)) (Callstate + (fid0, fd0, args0, dst', fs', m')) __) tr __ __)))) + | RTLabs_syntax.St_cost (c, l) -> + (fun _ _ -> + jmeq_hackT (IOMonad.Value { Types.fst = (Events.echarge c); + Types.snd = + (build_state { func = func0; locals = locals0; next = next0; sp = + sp0; retdst = dst0 } fs0 m0 l) }) (IOMonad.Value { Types.fst = + tr; Types.snd = (Callstate (fid0, fd0, args0, dst', fs', m')) }) + (fun _ -> + Obj.magic IOMonad.iO_jmdiscr (IOMonad.Value { Types.fst = + (Events.echarge c); Types.snd = + (build_state { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 } fs0 m0 l) }) (IOMonad.Value + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + (Events.echarge c); Types.snd = + (build_state { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 } fs0 m0 l) } { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', m')) } + __ (fun _ -> + Logic.eq_rect_Type0 (List.Cons ((Events.EVcost c), List.Nil)) + (fun _ _ _ -> + Obj.magic state_jmdiscr (State + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0, m0)) (Callstate + (fid0, fd0, args0, dst', fs', m')) __) tr __ __)))) + | RTLabs_syntax.St_const (t0, r, c, l) -> + (fun _ _ -> + IOMonad.bind_res_value + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedConstant) + (FrontEndOps.eval_constant t0 (Globalenvs.find_symbol ge) sp0 + c)) (fun v -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r v locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, dst', + fs', m')) } (fun v _ _ -> + bind_ok (reg_store r v locals0) (fun x1 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = x1; + next = l; sp = sp0; retdst = dst0 }, fs0, m0)) })) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun locals' _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals'; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals'; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }) + (Errors.OK { Types.fst = tr; Types.snd = (Callstate (fid0, + fd0, args0, dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = Events.e0; + Types.snd = (State ({ func = func0; locals = locals'; + next = l; sp = sp0; retdst = dst0 }, fs0, m0)) } + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, + args0, dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State ({ func = func0; + locals = locals'; next = l; sp = sp0; retdst = + dst0 }, fs0, m0)) (Callstate (fid0, fd0, args0, dst', + fs', m')) __) tr __ __)))))) + | RTLabs_syntax.St_op1 (t1, t2, op, r1, r2, l) -> + (fun _ _ -> + IOMonad.bind_res_value (reg_retrieve locals0 r2) (fun v -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_unop t2 t1 op v))) (fun v' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r1 v' locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) })))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, dst', + fs', m')) } (fun v _ _ -> + bind_ok + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_unop t2 t1 op v)) (fun x1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r1 x1 locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun v' _ _ -> + bind_ok (reg_store r1 v' locals0) (fun x1 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + x1; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) })) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun loc _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + loc; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + loc; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }) + (Errors.OK { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + loc; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) } + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, + args0, dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State ({ func = func0; + locals = loc; next = l; sp = sp0; retdst = dst0 }, + fs0, m0)) (Callstate (fid0, fd0, args0, dst', fs', + m')) __) tr __ __))))))) + | RTLabs_syntax.St_op2 (t1, t2, t', op, r1, r2, r3, l) -> + (fun _ _ -> + IOMonad.bind_res_value (reg_retrieve locals0 r2) (fun v1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0 r3)) (fun v2 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_binop m0 t2 t' t1 op v1 v2))) + (fun v' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r1 v' locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, + m0)) }))))) { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) } (fun v1 _ _ -> + bind_ok (reg_retrieve locals0 r3) (fun x1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_binop m0 t2 t' t1 op v1 x1))) + (fun v' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r1 v' locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, + m0)) })))) { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) } (fun v2 _ _ -> + bind_ok + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedOp) + (FrontEndOps.eval_binop m0 t2 t' t1 op v1 v2)) (fun x1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r1 x1 locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, + m0)) }))) { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) } (fun v' _ _ -> + bind_ok (reg_store r1 v' locals0) (fun x1 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) + { Types.fst = Events.e0; Types.snd = (State ({ func = + func0; locals = x1; next = l; sp = sp0; retdst = + dst0 }, fs0, m0)) })) { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) } + (fun loc _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) + { Types.fst = Events.e0; Types.snd = (State ({ func = + func0; locals = loc; next = l; sp = sp0; retdst = + dst0 }, fs0, m0)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + loc; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }) + (Errors.OK { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; + locals = loc; next = l; sp = sp0; retdst = dst0 }, + fs0, m0)) } { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State ({ func = func0; + locals = loc; next = l; sp = sp0; retdst = + dst0 }, fs0, m0)) (Callstate (fid0, fd0, args0, + dst', fs', m')) __) tr __ __)))))))) + | RTLabs_syntax.St_load (ch, r1, r2, l) -> + (fun _ _ -> + IOMonad.bind_res_value (reg_retrieve locals0 r1) (fun vaddr -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (FrontEndMem.loadv ch m0 vaddr))) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r2 v locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) })))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, dst', + fs', m')) } (fun v _ _ -> + bind_ok + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedLoad) + (FrontEndMem.loadv ch m0 v)) (fun x1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_store r2 x1 locals0)) (fun locals1 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + locals1; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun v' _ _ -> + bind_ok (reg_store r2 v' locals0) (fun x1 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + x1; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) })) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun loc _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + loc; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + loc; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) }) + (Errors.OK { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + Events.e0; Types.snd = (State ({ func = func0; locals = + loc; next = l; sp = sp0; retdst = dst0 }, fs0, m0)) } + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, + args0, dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State ({ func = func0; + locals = loc; next = l; sp = sp0; retdst = dst0 }, + fs0, m0)) (Callstate (fid0, fd0, args0, dst', fs', + m')) __) tr __ __))))))) + | RTLabs_syntax.St_store (ch, r1, r2, l) -> + (fun _ _ -> + IOMonad.bind_res_value (reg_retrieve locals0 r1) (fun vaddr -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0 r2)) (fun v -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedStore) + (FrontEndMem.storev ch m0 vaddr v))) (fun m'0 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 m'0 l) })))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, dst', + fs', m')) } (fun v _ _ -> + bind_ok (reg_retrieve locals0 r2) (fun x1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedStore) + (FrontEndMem.storev ch m0 v x1))) (fun m'0 -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 m'0 l) }))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun v' _ _ -> + bind_ok + (Errors.opt_to_res (Errors.msg ErrorMessages.FailedStore) + (FrontEndMem.storev ch m0 v v')) (fun x1 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 x1 l) })) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun loc _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 loc l) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 loc l) }) + (Errors.OK { Types.fst = tr; Types.snd = (Callstate + (fid0, fd0, args0, dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 loc l) } + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, + args0, dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State + ((adv l { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 }), fs0, loc)) + (Callstate (fid0, fd0, args0, dst', fs', m')) __) + tr __ __))))))) + | RTLabs_syntax.St_call_id (x1, rs, or0, l) -> + (fun _ _ -> + IOMonad.bind_res_value + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingSymbol), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, x1)), List.Nil)))) + (Globalenvs.find_symbol ge x1)) (fun b -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, x1)), List.Nil)))) + (Globalenvs.find_funct_ptr ge b))) (fun fd1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0)) rs) (fun vs -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (x1, fd1, vs, or0, + (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) })))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, dst', + fs', m')) } (fun v _ _ -> + bind_ok + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, x1)), List.Nil)))) + (Globalenvs.find_funct_ptr ge v)) (fun x2 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0)) rs) (fun vs -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (x1, x2, vs, or0, + (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) }))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun fd' _ _ -> + bind_ok + (Obj.magic + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0)) rs)) (fun x2 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (x1, fd', x2, or0, + (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) })) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun vs _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (x1, fd', vs, or0, + (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + List.Nil; Types.snd = (Callstate (x1, fd', vs, or0, + (List.Cons ({ func = func0; locals = locals0; next = l; + sp = sp0; retdst = dst0 }, fs0)), m0)) }) (Errors.OK + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, + args0, dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = List.Nil; + Types.snd = (Callstate (x1, fd', vs, or0, (List.Cons + ({ func = func0; locals = locals0; next = l; sp = sp0; + retdst = dst0 }, fs0)), m0)) } { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', + m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (Callstate (x1, fd', vs, or0, + (List.Cons ({ func = func0; locals = locals0; + next = l; sp = sp0; retdst = dst0 }, fs0)), m0)) + (Callstate (fid0, fd0, args0, dst', fs', m')) __ + (fun _ -> + Extralib.eq_rect_Type0_r fid0 (fun _ _ _ _ _ _ _ -> + Extralib.eq_rect_Type0_r fd0 (fun _ _ _ _ _ -> + Extralib.eq_rect_Type0_r args0 + (fun _ _ _ _ _ -> + Extralib.eq_rect_Type0_r dst' + (fun _ _ _ _ _ -> + Logic.eq_rect_Type0 (List.Cons ({ func = + func0; locals = locals0; next = l; sp = + sp0; retdst = dst0 }, fs0)) + (fun _ _ _ _ -> + Extralib.eq_rect_Type0_r m' (fun _ _ _ -> + Logic.streicherK (Errors.OK + { Types.fst = List.Nil; Types.snd = + (Callstate (fid0, fd0, args0, dst', + (List.Cons ({ func = func0; locals = + locals0; next = l; sp = sp0; retdst = + dst0 }, fs0)), m')) }) + (Logic.streicherK { Types.fst = + List.Nil; Types.snd = (Callstate + (fid0, fd0, args0, dst', (List.Cons + ({ func = func0; locals = locals0; + next = l; sp = sp0; retdst = + dst0 }, fs0)), m')) } + (Logic.streicherK (Callstate (fid0, + fd0, args0, dst', (List.Cons + ({ func = func0; locals = + locals0; next = l; sp = sp0; + retdst = dst0 }, fs0)), m')) v))) + m0 __ __ __) fs' __ __ __) or0 __ __ __ + __) vs __ __ __ __) fd' __ __ __ __) x1 __ + __ __ __ __ __)) tr __ __))))))) + | RTLabs_syntax.St_call_ptr (x1, rs, or0, l) -> + (fun _ _ -> + IOMonad.bind_res_value (reg_retrieve locals0 x1) (fun fv -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (Errors.msg ErrorMessages.BadFunction) + (Globalenvs.find_funct_id ge fv))) (fun fd1 id -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0)) rs) (fun vs -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (id, fd1, vs, or0, + (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) })))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, dst', + fs', m')) } (fun v _ _ -> + bind_ok + (Errors.opt_to_res (Errors.msg ErrorMessages.BadFunction) + (Globalenvs.find_funct_id ge v)) (fun x2 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0)) rs) (fun vs -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (x2.Types.snd, + x2.Types.fst, vs, or0, (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) }))) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun fd' _ _ -> + bind_ok + (Obj.magic + (Monad.m_list_map (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0)) rs)) (fun x2 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (fd'.Types.snd, + fd'.Types.fst, x2, or0, (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) })) + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, args0, + dst', fs', m')) } (fun vs _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Callstate (fd'.Types.snd, + fd'.Types.fst, vs, or0, (List.Cons + ((adv l { func = func0; locals = locals0; next = next0; + sp = sp0; retdst = dst0 }), fs0)), m0)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + List.Nil; Types.snd = (Callstate (fd'.Types.snd, + fd'.Types.fst, vs, or0, (List.Cons ({ func = func0; + locals = locals0; next = l; sp = sp0; retdst = dst0 }, + fs0)), m0)) }) (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) }) __ + (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = List.Nil; + Types.snd = (Callstate (fd'.Types.snd, fd'.Types.fst, + vs, or0, (List.Cons ({ func = func0; locals = locals0; + next = l; sp = sp0; retdst = dst0 }, fs0)), m0)) } + { Types.fst = tr; Types.snd = (Callstate (fid0, fd0, + args0, dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (Callstate (fd'.Types.snd, + fd'.Types.fst, vs, or0, (List.Cons ({ func = func0; + locals = locals0; next = l; sp = sp0; retdst = + dst0 }, fs0)), m0)) (Callstate (fid0, fd0, args0, + dst', fs', m')) __ (fun _ -> + Logic.eq_rect_Type0 fd'.Types.snd (fun _ _ _ _ -> + Logic.eq_rect_Type0 fd'.Types.fst (fun _ _ _ _ -> + Extralib.eq_rect_Type0_r args0 + (fun _ _ _ _ _ -> + Extralib.eq_rect_Type0_r dst' + (fun _ _ _ _ _ -> + Logic.eq_rect_Type0 (List.Cons ({ func = + func0; locals = locals0; next = l; sp = + sp0; retdst = dst0 }, fs0)) + (fun _ _ _ _ -> + Extralib.eq_rect_Type0_r m' (fun _ _ _ -> + Logic.streicherK (Errors.OK + { Types.fst = List.Nil; Types.snd = + (Callstate (fd'.Types.snd, + fd'.Types.fst, args0, dst', + (List.Cons ({ func = func0; locals = + locals0; next = l; sp = sp0; retdst = + dst0 }, fs0)), m')) }) + (Logic.streicherK { Types.fst = + List.Nil; Types.snd = (Callstate + (fd'.Types.snd, fd'.Types.fst, + args0, dst', (List.Cons ({ func = + func0; locals = locals0; next = l; + sp = sp0; retdst = dst0 }, fs0)), + m')) } + (Logic.streicherK (Callstate + (fd'.Types.snd, fd'.Types.fst, + args0, dst', (List.Cons ({ func = + func0; locals = locals0; next = + l; sp = sp0; retdst = dst0 }, + fs0)), m')) + ((match v with + | Values.Vundef -> + (fun _ -> + Obj.magic Errors.res_discr + (Errors.Error (List.Cons + ((Errors.MSG + ErrorMessages.BadFunction), + List.Nil))) (Errors.OK + fd') __) + | Values.Vint (a, b) -> + (fun _ -> + Obj.magic Errors.res_discr + (Errors.Error (List.Cons + ((Errors.MSG + ErrorMessages.BadFunction), + List.Nil))) (Errors.OK + fd') __) + | Values.Vnull -> + (fun _ -> + Obj.magic Errors.res_discr + (Errors.Error (List.Cons + ((Errors.MSG + ErrorMessages.BadFunction), + List.Nil))) (Errors.OK + fd') __) + | Values.Vptr clearme1 -> + let { Pointers.pblock = b; + Pointers.poff = off } = + clearme1 + in + let { Types.fst = fd''; + Types.snd = fid' } = fd' + in + (fun _ -> b)) __)))) m0 __ __ + __) fs' __ __ __) or0 __ __ __ __) vs + __ __ __ __) fd0 __ __ __) fid0 __ __ __)) tr + __ __))))))) + | RTLabs_syntax.St_cond (r, l1, l2) -> + (fun _ _ -> + IOMonad.bind_res_value (reg_retrieve locals0 r) (fun v -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Values.eval_bool_of_val v)) (fun b -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 m0 + (match b with + | Bool.True -> l1 + | Bool.False -> l2)) }))) { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) } (fun v _ _ -> + bind_ok (Values.eval_bool_of_val v) (fun x1 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 m0 + (match x1 with + | Bool.True -> l1 + | Bool.False -> l2)) })) { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) } (fun b _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 m0 + (match b with + | Bool.True -> l1 + | Bool.False -> l2)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 m0 + (match b with + | Bool.True -> l1 + | Bool.False -> l2)) }) (Errors.OK { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', + m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = Events.e0; + Types.snd = + (build_state { func = func0; locals = locals0; next = + next0; sp = sp0; retdst = dst0 } fs0 m0 + (match b with + | Bool.True -> l1 + | Bool.False -> l2)) } { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) } __ + (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State + ((adv + (match b with + | Bool.True -> l1 + | Bool.False -> l2) { func = func0; locals = + locals0; next = next0; sp = sp0; retdst = dst0 }), + fs0, m0)) (Callstate (fid0, fd0, args0, dst', fs', + m')) __) tr __ __)))))) + | RTLabs_syntax.St_return -> + (fun _ _ -> + IOMonad.bind_res_value + (match func0.RTLabs_syntax.f_result with + | Types.None -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) Types.None) + | Types.Some rt -> + let { Types.fst = r; Types.snd = ty } = rt in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (reg_retrieve locals0 r)) (fun v -> + Monad.m_return0 (Monad.max_def Errors.res0) (Types.Some v)))) + (fun v -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) })) { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) } (fun v -> + match func0.RTLabs_syntax.f_result with + | Types.None -> + (fun _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_discr (Errors.OK Types.None) + (Errors.OK v) __ + (Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) }) (Errors.OK { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', + m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + Events.e0; Types.snd = (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) } { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', + m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) (Callstate (fid0, fd0, + args0, dst', fs', m')) __) tr __ __))))) + | Types.Some clearme1 -> + let { Types.fst = r; Types.snd = t0 } = clearme1 in + (fun _ -> + bind_ok (reg_retrieve locals0 r) (fun x1 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) (Types.Some + x1))) v (fun v0 _ _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = + (Callstate (fid0, fd0, args0, dst', fs', m')) })) + (fun _ -> + Obj.magic Errors.res_discr (Errors.OK (Types.Some v0)) + (Errors.OK v) __ + (Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) }) (Errors.OK { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', + m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + Events.e0; Types.snd = (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) } { Types.fst = tr; + Types.snd = (Callstate (fid0, fd0, args0, dst', fs', + m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (Returnstate (v, dst0, fs0, + (GenMem.free m0 sp0))) (Callstate (fid0, fd0, + args0, dst', fs', m')) __) tr __ __))))))))) __)) + x x0 + | Callstate (vf, clearme0, x, x0, x1, x2) -> + (match clearme0 with + | AST.Internal fn -> + (fun args0 retdst0 stk m0 tr vf' fd' args' dst' fs' m' _ -> + IOMonad.bind_res_value + (params_store fn.RTLabs_syntax.f_params args0 + (init_locals fn.RTLabs_syntax.f_locals)) (fun locals0 -> + let { Types.fst = m'0; Types.snd = sp0 } = + GenMem.alloc m0 (Z.z_of_nat Nat.O) + (Z.z_of_nat fn.RTLabs_syntax.f_stacksize) + in + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = fn; locals = locals0; + next = (Types.pi1 fn.RTLabs_syntax.f_entry); sp = sp0; + retdst = retdst0 }, stk, m'0)) })) { Types.fst = tr; + Types.snd = (Callstate (vf', fd', args', dst', fs', m')) } + (fun loc _ -> + let { Types.fst = m'0; Types.snd = b } = + GenMem.alloc m0 (Z.z_of_nat Nat.O) + (Z.z_of_nat fn.RTLabs_syntax.f_stacksize) + in + (fun _ -> + jmeq_hackT (Errors.OK { Types.fst = Events.e0; Types.snd = (State + ({ func = fn; locals = loc; next = + (Types.pi1 fn.RTLabs_syntax.f_entry); sp = b; retdst = + retdst0 }, stk, m'0)) }) (Errors.OK { Types.fst = tr; + Types.snd = (Callstate (vf', fd', args', dst', fs', m')) }) + (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (State ({ func = fn; locals = loc; + next = (Types.pi1 fn.RTLabs_syntax.f_entry); sp = b; retdst = + retdst0 }, stk, m'0)) }) (Errors.OK { Types.fst = tr; + Types.snd = (Callstate (vf', fd', args', dst', fs', m')) }) + __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = Events.e0; + Types.snd = (State ({ func = fn; locals = loc; next = + (Types.pi1 fn.RTLabs_syntax.f_entry); sp = b; retdst = + retdst0 }, stk, m'0)) } { Types.fst = tr; Types.snd = + (Callstate (vf', fd', args', dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State ({ func = fn; locals = + loc; next = (Types.pi1 fn.RTLabs_syntax.f_entry); sp = + b; retdst = retdst0 }, stk, m'0)) (Callstate (vf', fd', + args', dst', fs', m')) __) tr __ __)))))) + | AST.External fn -> + (fun args0 retdst0 stk m0 tr vf' fd' args' dst' fs' m' _ -> + IOMonad.bindIO_value + (IOMonad.err_to_io + (IO.check_eventval_list args0 fn.AST.ef_sig.AST.sig_args)) + (fun evargs -> + Obj.magic + (Monad.m_bind0 (Monad.max_def IOMonad.iOMonad) + (Obj.magic + (IO.do_io fn.AST.ef_id evargs + (AST.proj_sig_res fn.AST.ef_sig))) (fun evres -> + Monad.m_return0 (Monad.max_def IOMonad.iOMonad) { Types.fst = + (Events.eextcall fn.AST.ef_id evargs + (IO.mk_eventval (AST.proj_sig_res fn.AST.ef_sig) evres)); + Types.snd = (Returnstate ((Types.Some + (IO.mk_val (AST.proj_sig_res fn.AST.ef_sig) evres)), + retdst0, stk, m0)) }))) { Types.fst = tr; Types.snd = + (Callstate (vf', fd', args', dst', fs', m')) } (fun evargs _ _ -> + Obj.magic IOMonad.iO_discr (IOMonad.Interact ({ IO.io_function = + fn.AST.ef_id; IO.io_args = evargs; IO.io_in_typ = + (AST.proj_sig_res fn.AST.ef_sig) }, (fun res -> + IOMonad.bindIO (IOMonad.Value res) (fun evres -> + Obj.magic + (Monad.m_return0 (Monad.max_def IOMonad.iOMonad) + { Types.fst = + (Events.eextcall fn.AST.ef_id evargs + (IO.mk_eventval (AST.proj_sig_res fn.AST.ef_sig) evres)); + Types.snd = (Returnstate ((Types.Some + (IO.mk_val (AST.proj_sig_res fn.AST.ef_sig) evres)), + retdst0, stk, m0)) }))))) (IOMonad.Value { Types.fst = + tr; Types.snd = (Callstate (vf', fd', args', dst', fs', m')) }) + __))) x x0 x1 x2 + | Returnstate (v, r, clearme0, x) -> + (match clearme0 with + | List.Nil -> + (fun m0 tr vf' fd' args' dst' fs' m' -> + match v with + | Types.None -> + (fun _ -> + Obj.magic IOMonad.iO_discr (IOMonad.Wrong (List.Cons + ((Errors.MSG ErrorMessages.ReturnMismatch), List.Nil))) + (IOMonad.Value { Types.fst = tr; Types.snd = (Callstate (vf', + fd', args', dst', fs', m')) }) __) + | Types.Some clearme1 -> + (match clearme1 with + | Values.Vundef -> + (fun _ -> + Obj.magic IOMonad.iO_discr (IOMonad.Wrong (List.Cons + ((Errors.MSG ErrorMessages.ReturnMismatch), List.Nil))) + (IOMonad.Value { Types.fst = tr; Types.snd = (Callstate + (vf', fd', args', dst', fs', m')) }) __) + | Values.Vint (clearme2, x0) -> + (match clearme2 with + | AST.I8 -> + (fun r0 _ -> + jmeq_hackT (IOMonad.Wrong (List.Cons ((Errors.MSG + ErrorMessages.ReturnMismatch), List.Nil))) + (IOMonad.Value { Types.fst = tr; Types.snd = (Callstate + (vf', fd', args', dst', fs', m')) }) (fun _ -> + Obj.magic IOMonad.iO_jmdiscr (IOMonad.Wrong (List.Cons + ((Errors.MSG ErrorMessages.ReturnMismatch), + List.Nil))) (IOMonad.Value { Types.fst = tr; + Types.snd = (Callstate (vf', fd', args', dst', fs', + m')) }) __)) + | AST.I16 -> + (fun r0 _ -> + jmeq_hackT (IOMonad.Wrong (List.Cons ((Errors.MSG + ErrorMessages.ReturnMismatch), List.Nil))) + (IOMonad.Value { Types.fst = tr; Types.snd = (Callstate + (vf', fd', args', dst', fs', m')) }) (fun _ -> + Obj.magic IOMonad.iO_jmdiscr (IOMonad.Wrong (List.Cons + ((Errors.MSG ErrorMessages.ReturnMismatch), + List.Nil))) (IOMonad.Value { Types.fst = tr; + Types.snd = (Callstate (vf', fd', args', dst', fs', + m')) }) __)) + | AST.I32 -> + (fun r0 _ -> + jmeq_hackT (IOMonad.Value { Types.fst = List.Nil; + Types.snd = (Finalstate r0) }) (IOMonad.Value + { Types.fst = tr; Types.snd = (Callstate (vf', fd', + args', dst', fs', m')) }) (fun _ -> + Obj.magic IOMonad.iO_jmdiscr (IOMonad.Value + { Types.fst = List.Nil; Types.snd = (Finalstate + r0) }) (IOMonad.Value { Types.fst = tr; Types.snd = + (Callstate (vf', fd', args', dst', fs', m')) }) __ + (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = + List.Nil; Types.snd = (Finalstate r0) } + { Types.fst = tr; Types.snd = (Callstate (vf', fd', + args', dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (Finalstate r0) + (Callstate (vf', fd', args', dst', fs', m')) __) + tr __ __))))) x0 + | Values.Vnull -> + (fun _ -> + Obj.magic IOMonad.iO_discr (IOMonad.Wrong (List.Cons + ((Errors.MSG ErrorMessages.ReturnMismatch), List.Nil))) + (IOMonad.Value { Types.fst = tr; Types.snd = (Callstate + (vf', fd', args', dst', fs', m')) }) __) + | Values.Vptr a -> + (fun _ -> + Obj.magic IOMonad.iO_discr (IOMonad.Wrong (List.Cons + ((Errors.MSG ErrorMessages.ReturnMismatch), List.Nil))) + (IOMonad.Value { Types.fst = tr; Types.snd = (Callstate + (vf', fd', args', dst', fs', m')) }) __))) + | List.Cons (f, fs0) -> + (fun m0 tr vf' fd' args' dst' fs' m' _ -> + IOMonad.bind_res_value + (match r with + | Types.None -> + (match v with + | Types.None -> Errors.OK f.locals + | Types.Some x0 -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch)) + | Types.Some d -> + (match v with + | Types.None -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch) + | Types.Some v' -> reg_store d v' f.locals)) (fun locals0 -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = + locals0; next = f.next; sp = f.sp; retdst = f.retdst }, fs0, + m0)) })) { Types.fst = tr; Types.snd = (Callstate (vf', fd', + args', dst', fs', m')) } (fun loc _ _ -> + jmeq_hackT + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = loc; + next = f.next; sp = f.sp; retdst = f.retdst }, fs0, m0)) }) + (Obj.magic (Errors.OK { Types.fst = tr; Types.snd = (Callstate + (vf', fd', args', dst', fs', m')) })) (fun _ -> + Obj.magic Errors.res_jmdiscr (Errors.OK { Types.fst = + Events.e0; Types.snd = (State ({ func = f.func; locals = loc; + next = f.next; sp = f.sp; retdst = f.retdst }, fs0, m0)) }) + (Errors.OK { Types.fst = tr; Types.snd = (Callstate (vf', + fd', args', dst', fs', m')) }) __ (fun _ -> + Obj.magic Globalenvs.prod_jmdiscr { Types.fst = Events.e0; + Types.snd = (State ({ func = f.func; locals = loc; next = + f.next; sp = f.sp; retdst = f.retdst }, fs0, m0)) } + { Types.fst = tr; Types.snd = (Callstate (vf', fd', args', + dst', fs', m')) } __ (fun _ -> + Logic.eq_rect_Type0 List.Nil (fun _ _ _ -> + Obj.magic state_jmdiscr (State ({ func = f.func; locals = + loc; next = f.next; sp = f.sp; retdst = f.retdst }, + fs0, m0)) (Callstate (vf', fd', args', dst', fs', m')) + __) tr __ __)))))) x + | Finalstate r -> + (fun tr vf' fd' args' dst' fs' m' _ -> + Obj.magic IOMonad.iO_discr (IOMonad.Wrong (List.Cons ((Errors.MSG + ErrorMessages.FinalState), List.Nil))) (IOMonad.Value { Types.fst = + tr; Types.snd = (Callstate (vf', fd', args', dst', fs', m')) }) __)) + t fid fd args dst fs m __ + diff --git a/extracted/rTLabs_semantics.mli b/extracted/rTLabs_semantics.mli new file mode 100644 index 0000000..39667e8 --- /dev/null +++ b/extracted/rTLabs_semantics.mli @@ -0,0 +1,336 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open CostLabel + +open Events + +open IOMonad + +open IO + +open SmallstepExec + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +type genv = RTLabs_syntax.internal_function AST.fundef Globalenvs.genv_t + +type frame = { func : RTLabs_syntax.internal_function; + locals : Values.val0 Registers.register_env; + next : Graphs.label; sp : Pointers.block; + retdst : Registers.register Types.option } + +val frame_rect_Type4 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option -> + 'a1) -> frame -> 'a1 + +val frame_rect_Type5 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option -> + 'a1) -> frame -> 'a1 + +val frame_rect_Type3 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option -> + 'a1) -> frame -> 'a1 + +val frame_rect_Type2 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option -> + 'a1) -> frame -> 'a1 + +val frame_rect_Type1 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option -> + 'a1) -> frame -> 'a1 + +val frame_rect_Type0 : + (RTLabs_syntax.internal_function -> Values.val0 Registers.register_env -> + Graphs.label -> __ -> Pointers.block -> Registers.register Types.option -> + 'a1) -> frame -> 'a1 + +val func : frame -> RTLabs_syntax.internal_function + +val locals : frame -> Values.val0 Registers.register_env + +val next : frame -> Graphs.label + +val sp : frame -> Pointers.block + +val retdst : frame -> Registers.register Types.option + +val frame_inv_rect_Type4 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type3 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type2 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type1 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 + +val frame_inv_rect_Type0 : + frame -> (RTLabs_syntax.internal_function -> Values.val0 + Registers.register_env -> Graphs.label -> __ -> Pointers.block -> + Registers.register Types.option -> __ -> 'a1) -> 'a1 + +val frame_jmdiscr : frame -> frame -> __ + +val adv : Graphs.label -> frame -> frame + +type state = +| State of frame * frame List.list * GenMem.mem +| Callstate of AST.ident * RTLabs_syntax.internal_function AST.fundef + * Values.val0 List.list * Registers.register Types.option + * frame List.list * GenMem.mem +| Returnstate of Values.val0 Types.option * Registers.register Types.option + * frame List.list * GenMem.mem +| Finalstate of Integers.int + +val state_rect_Type4 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) -> + (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type5 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) -> + (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type3 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) -> + (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type2 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) -> + (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type1 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) -> + (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_rect_Type0 : + (frame -> frame List.list -> GenMem.mem -> 'a1) -> (AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> 'a1) -> + (Values.val0 Types.option -> Registers.register Types.option -> frame + List.list -> GenMem.mem -> 'a1) -> (Integers.int -> 'a1) -> state -> 'a1 + +val state_inv_rect_Type4 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> Registers.register + Types.option -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type3 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> Registers.register + Types.option -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type2 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> Registers.register + Types.option -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type1 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> Registers.register + Types.option -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 + +val state_inv_rect_Type0 : + state -> (frame -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (AST.ident -> RTLabs_syntax.internal_function AST.fundef -> Values.val0 + List.list -> Registers.register Types.option -> frame List.list -> + GenMem.mem -> __ -> 'a1) -> (Values.val0 Types.option -> Registers.register + Types.option -> frame List.list -> GenMem.mem -> __ -> 'a1) -> + (Integers.int -> __ -> 'a1) -> 'a1 + +val state_jmdiscr : state -> state -> __ + +val build_state : + frame -> frame List.list -> GenMem.mem -> Graphs.label -> state + +val next_instruction : frame -> RTLabs_syntax.statement + +val init_locals : + (Registers.register, AST.typ) Types.prod List.list -> Values.val0 + Registers.register_env + +val reg_store : + PreIdentifiers.identifier -> Values.val0 -> Values.val0 + Identifiers.identifier_map -> Values.val0 Identifiers.identifier_map + Errors.res + +val params_store : + (Registers.register, AST.typ) Types.prod List.list -> Values.val0 List.list + -> Values.val0 Registers.register_env -> Values.val0 Registers.register_env + Errors.res + +val reg_retrieve : + Values.val0 Registers.register_env -> Registers.register -> Values.val0 + Errors.res + +val eval_statement : + genv -> state -> (IO.io_out, IO.io_in, (Events.trace, state) Types.prod) + IOMonad.iO + +val rTLabs_is_final : state -> Integers.int Types.option + +val rTLabs_exec : (IO.io_out, IO.io_in) SmallstepExec.trans_system + +val make_global : RTLabs_syntax.rTLabs_program -> genv + +val make_initial_state : RTLabs_syntax.rTLabs_program -> state Errors.res + +val rTLabs_fullexec : (IO.io_out, IO.io_in) SmallstepExec.fullexec + +val bind_ok : + 'a1 Errors.res -> ('a1 -> 'a2 Errors.res) -> 'a2 -> ('a1 -> __ -> __ -> + 'a3) -> 'a3 + +val jmeq_hackT : 'a1 -> 'a1 -> (__ -> 'a2) -> 'a2 + +val func_block_of_exec : + genv -> state -> Events.trace -> AST.ident -> + RTLabs_syntax.internal_function AST.fundef -> Values.val0 List.list -> + Registers.register Types.option -> frame List.list -> GenMem.mem -> + Pointers.block Types.sig0 + diff --git a/extracted/rTLabs_syntax.ml b/extracted/rTLabs_syntax.ml new file mode 100644 index 0000000..1175644 --- /dev/null +++ b/extracted/rTLabs_syntax.ml @@ -0,0 +1,653 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open CostLabel + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open Order + +open Registers + +open BitVectorTrie + +open Graphs + +type statement = +| St_skip of Graphs.label +| St_cost of CostLabel.costlabel * Graphs.label +| St_const of AST.typ * Registers.register * FrontEndOps.constant + * Graphs.label +| St_op1 of AST.typ * AST.typ * FrontEndOps.unary_operation + * Registers.register * Registers.register * Graphs.label +| St_op2 of AST.typ * AST.typ * AST.typ * FrontEndOps.binary_operation + * Registers.register * Registers.register * Registers.register + * Graphs.label +| St_load of AST.typ * Registers.register * Registers.register * Graphs.label +| St_store of AST.typ * Registers.register * Registers.register + * Graphs.label +| St_call_id of AST.ident * Registers.register List.list + * Registers.register Types.option * Graphs.label +| St_call_ptr of Registers.register * Registers.register List.list + * Registers.register Types.option * Graphs.label +| St_cond of Registers.register * Graphs.label * Graphs.label +| St_return + +(** val statement_rect_Type4 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> 'a1) -> 'a1 -> statement -> 'a1 **) +let rec statement_rect_Type4 h_St_skip h_St_cost h_St_const h_St_op1 h_St_op2 h_St_load h_St_store h_St_call_id h_St_call_ptr h_St_cond h_St_return = function +| St_skip x_14903 -> h_St_skip x_14903 +| St_cost (x_14905, x_14904) -> h_St_cost x_14905 x_14904 +| St_const (t, x_14908, x_14907, x_14906) -> + h_St_const t x_14908 x_14907 x_14906 +| St_op1 (t', t, x_14912, x_14911, x_14910, x_14909) -> + h_St_op1 t' t x_14912 x_14911 x_14910 x_14909 +| St_op2 (t', t1, t2, x_14917, x_14916, x_14915, x_14914, x_14913) -> + h_St_op2 t' t1 t2 x_14917 x_14916 x_14915 x_14914 x_14913 +| St_load (x_14921, x_14920, x_14919, x_14918) -> + h_St_load x_14921 x_14920 x_14919 x_14918 +| St_store (x_14925, x_14924, x_14923, x_14922) -> + h_St_store x_14925 x_14924 x_14923 x_14922 +| St_call_id (x_14929, x_14928, x_14927, x_14926) -> + h_St_call_id x_14929 x_14928 x_14927 x_14926 +| St_call_ptr (x_14933, x_14932, x_14931, x_14930) -> + h_St_call_ptr x_14933 x_14932 x_14931 x_14930 +| St_cond (x_14936, x_14935, x_14934) -> h_St_cond x_14936 x_14935 x_14934 +| St_return -> h_St_return + +(** val statement_rect_Type5 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> 'a1) -> 'a1 -> statement -> 'a1 **) +let rec statement_rect_Type5 h_St_skip h_St_cost h_St_const h_St_op1 h_St_op2 h_St_load h_St_store h_St_call_id h_St_call_ptr h_St_cond h_St_return = function +| St_skip x_14949 -> h_St_skip x_14949 +| St_cost (x_14951, x_14950) -> h_St_cost x_14951 x_14950 +| St_const (t, x_14954, x_14953, x_14952) -> + h_St_const t x_14954 x_14953 x_14952 +| St_op1 (t', t, x_14958, x_14957, x_14956, x_14955) -> + h_St_op1 t' t x_14958 x_14957 x_14956 x_14955 +| St_op2 (t', t1, t2, x_14963, x_14962, x_14961, x_14960, x_14959) -> + h_St_op2 t' t1 t2 x_14963 x_14962 x_14961 x_14960 x_14959 +| St_load (x_14967, x_14966, x_14965, x_14964) -> + h_St_load x_14967 x_14966 x_14965 x_14964 +| St_store (x_14971, x_14970, x_14969, x_14968) -> + h_St_store x_14971 x_14970 x_14969 x_14968 +| St_call_id (x_14975, x_14974, x_14973, x_14972) -> + h_St_call_id x_14975 x_14974 x_14973 x_14972 +| St_call_ptr (x_14979, x_14978, x_14977, x_14976) -> + h_St_call_ptr x_14979 x_14978 x_14977 x_14976 +| St_cond (x_14982, x_14981, x_14980) -> h_St_cond x_14982 x_14981 x_14980 +| St_return -> h_St_return + +(** val statement_rect_Type3 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> 'a1) -> 'a1 -> statement -> 'a1 **) +let rec statement_rect_Type3 h_St_skip h_St_cost h_St_const h_St_op1 h_St_op2 h_St_load h_St_store h_St_call_id h_St_call_ptr h_St_cond h_St_return = function +| St_skip x_14995 -> h_St_skip x_14995 +| St_cost (x_14997, x_14996) -> h_St_cost x_14997 x_14996 +| St_const (t, x_15000, x_14999, x_14998) -> + h_St_const t x_15000 x_14999 x_14998 +| St_op1 (t', t, x_15004, x_15003, x_15002, x_15001) -> + h_St_op1 t' t x_15004 x_15003 x_15002 x_15001 +| St_op2 (t', t1, t2, x_15009, x_15008, x_15007, x_15006, x_15005) -> + h_St_op2 t' t1 t2 x_15009 x_15008 x_15007 x_15006 x_15005 +| St_load (x_15013, x_15012, x_15011, x_15010) -> + h_St_load x_15013 x_15012 x_15011 x_15010 +| St_store (x_15017, x_15016, x_15015, x_15014) -> + h_St_store x_15017 x_15016 x_15015 x_15014 +| St_call_id (x_15021, x_15020, x_15019, x_15018) -> + h_St_call_id x_15021 x_15020 x_15019 x_15018 +| St_call_ptr (x_15025, x_15024, x_15023, x_15022) -> + h_St_call_ptr x_15025 x_15024 x_15023 x_15022 +| St_cond (x_15028, x_15027, x_15026) -> h_St_cond x_15028 x_15027 x_15026 +| St_return -> h_St_return + +(** val statement_rect_Type2 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> 'a1) -> 'a1 -> statement -> 'a1 **) +let rec statement_rect_Type2 h_St_skip h_St_cost h_St_const h_St_op1 h_St_op2 h_St_load h_St_store h_St_call_id h_St_call_ptr h_St_cond h_St_return = function +| St_skip x_15041 -> h_St_skip x_15041 +| St_cost (x_15043, x_15042) -> h_St_cost x_15043 x_15042 +| St_const (t, x_15046, x_15045, x_15044) -> + h_St_const t x_15046 x_15045 x_15044 +| St_op1 (t', t, x_15050, x_15049, x_15048, x_15047) -> + h_St_op1 t' t x_15050 x_15049 x_15048 x_15047 +| St_op2 (t', t1, t2, x_15055, x_15054, x_15053, x_15052, x_15051) -> + h_St_op2 t' t1 t2 x_15055 x_15054 x_15053 x_15052 x_15051 +| St_load (x_15059, x_15058, x_15057, x_15056) -> + h_St_load x_15059 x_15058 x_15057 x_15056 +| St_store (x_15063, x_15062, x_15061, x_15060) -> + h_St_store x_15063 x_15062 x_15061 x_15060 +| St_call_id (x_15067, x_15066, x_15065, x_15064) -> + h_St_call_id x_15067 x_15066 x_15065 x_15064 +| St_call_ptr (x_15071, x_15070, x_15069, x_15068) -> + h_St_call_ptr x_15071 x_15070 x_15069 x_15068 +| St_cond (x_15074, x_15073, x_15072) -> h_St_cond x_15074 x_15073 x_15072 +| St_return -> h_St_return + +(** val statement_rect_Type1 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> 'a1) -> 'a1 -> statement -> 'a1 **) +let rec statement_rect_Type1 h_St_skip h_St_cost h_St_const h_St_op1 h_St_op2 h_St_load h_St_store h_St_call_id h_St_call_ptr h_St_cond h_St_return = function +| St_skip x_15087 -> h_St_skip x_15087 +| St_cost (x_15089, x_15088) -> h_St_cost x_15089 x_15088 +| St_const (t, x_15092, x_15091, x_15090) -> + h_St_const t x_15092 x_15091 x_15090 +| St_op1 (t', t, x_15096, x_15095, x_15094, x_15093) -> + h_St_op1 t' t x_15096 x_15095 x_15094 x_15093 +| St_op2 (t', t1, t2, x_15101, x_15100, x_15099, x_15098, x_15097) -> + h_St_op2 t' t1 t2 x_15101 x_15100 x_15099 x_15098 x_15097 +| St_load (x_15105, x_15104, x_15103, x_15102) -> + h_St_load x_15105 x_15104 x_15103 x_15102 +| St_store (x_15109, x_15108, x_15107, x_15106) -> + h_St_store x_15109 x_15108 x_15107 x_15106 +| St_call_id (x_15113, x_15112, x_15111, x_15110) -> + h_St_call_id x_15113 x_15112 x_15111 x_15110 +| St_call_ptr (x_15117, x_15116, x_15115, x_15114) -> + h_St_call_ptr x_15117 x_15116 x_15115 x_15114 +| St_cond (x_15120, x_15119, x_15118) -> h_St_cond x_15120 x_15119 x_15118 +| St_return -> h_St_return + +(** val statement_rect_Type0 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> 'a1) -> 'a1 -> statement -> 'a1 **) +let rec statement_rect_Type0 h_St_skip h_St_cost h_St_const h_St_op1 h_St_op2 h_St_load h_St_store h_St_call_id h_St_call_ptr h_St_cond h_St_return = function +| St_skip x_15133 -> h_St_skip x_15133 +| St_cost (x_15135, x_15134) -> h_St_cost x_15135 x_15134 +| St_const (t, x_15138, x_15137, x_15136) -> + h_St_const t x_15138 x_15137 x_15136 +| St_op1 (t', t, x_15142, x_15141, x_15140, x_15139) -> + h_St_op1 t' t x_15142 x_15141 x_15140 x_15139 +| St_op2 (t', t1, t2, x_15147, x_15146, x_15145, x_15144, x_15143) -> + h_St_op2 t' t1 t2 x_15147 x_15146 x_15145 x_15144 x_15143 +| St_load (x_15151, x_15150, x_15149, x_15148) -> + h_St_load x_15151 x_15150 x_15149 x_15148 +| St_store (x_15155, x_15154, x_15153, x_15152) -> + h_St_store x_15155 x_15154 x_15153 x_15152 +| St_call_id (x_15159, x_15158, x_15157, x_15156) -> + h_St_call_id x_15159 x_15158 x_15157 x_15156 +| St_call_ptr (x_15163, x_15162, x_15161, x_15160) -> + h_St_call_ptr x_15163 x_15162 x_15161 x_15160 +| St_cond (x_15166, x_15165, x_15164) -> h_St_cond x_15166 x_15165 x_15164 +| St_return -> h_St_return + +(** val statement_inv_rect_Type4 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> AST.typ -> FrontEndOps.binary_operation -> Registers.register -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> + __ -> 'a1) -> (AST.typ -> Registers.register -> Registers.register -> + Graphs.label -> __ -> 'a1) -> (AST.ident -> Registers.register List.list + -> Registers.register Types.option -> Graphs.label -> __ -> 'a1) -> + (Registers.register -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let statement_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 = + let hcut = statement_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 hterm in + hcut __ + +(** val statement_inv_rect_Type3 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> AST.typ -> FrontEndOps.binary_operation -> Registers.register -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> + __ -> 'a1) -> (AST.typ -> Registers.register -> Registers.register -> + Graphs.label -> __ -> 'a1) -> (AST.ident -> Registers.register List.list + -> Registers.register Types.option -> Graphs.label -> __ -> 'a1) -> + (Registers.register -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let statement_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 = + let hcut = statement_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 hterm in + hcut __ + +(** val statement_inv_rect_Type2 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> AST.typ -> FrontEndOps.binary_operation -> Registers.register -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> + __ -> 'a1) -> (AST.typ -> Registers.register -> Registers.register -> + Graphs.label -> __ -> 'a1) -> (AST.ident -> Registers.register List.list + -> Registers.register Types.option -> Graphs.label -> __ -> 'a1) -> + (Registers.register -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let statement_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 = + let hcut = statement_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 hterm in + hcut __ + +(** val statement_inv_rect_Type1 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> AST.typ -> FrontEndOps.binary_operation -> Registers.register -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> + __ -> 'a1) -> (AST.typ -> Registers.register -> Registers.register -> + Graphs.label -> __ -> 'a1) -> (AST.ident -> Registers.register List.list + -> Registers.register Types.option -> Graphs.label -> __ -> 'a1) -> + (Registers.register -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let statement_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 = + let hcut = statement_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 hterm in + hcut __ + +(** val statement_inv_rect_Type0 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> AST.typ -> FrontEndOps.binary_operation -> Registers.register -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> + __ -> 'a1) -> (AST.typ -> Registers.register -> Registers.register -> + Graphs.label -> __ -> 'a1) -> (AST.ident -> Registers.register List.list + -> Registers.register Types.option -> Graphs.label -> __ -> 'a1) -> + (Registers.register -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Graphs.label -> Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let statement_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 = + let hcut = statement_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 hterm in + hcut __ + +(** val statement_jmdiscr : statement -> statement -> __ **) +let statement_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | St_skip a0 -> Obj.magic (fun _ dH -> dH __) + | St_cost (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | St_const (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | St_op1 (a0, a1, a2, a3, a4, a5) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __) + | St_op2 (a0, a1, a2, a3, a4, a5, a6, a7) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __) + | St_load (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | St_store (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | St_call_id (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | St_call_ptr (a0, a1, a2, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | St_cond (a0, a1, a2) -> Obj.magic (fun _ dH -> dH __ __ __) + | St_return -> Obj.magic (fun _ dH -> dH)) y + +type internal_function = { f_labgen : Identifiers.universe; + f_reggen : Identifiers.universe; + f_result : (Registers.register, AST.typ) + Types.prod Types.option; + f_params : (Registers.register, AST.typ) + Types.prod List.list; + f_locals : (Registers.register, AST.typ) + Types.prod List.list; + f_stacksize : Nat.nat; + f_graph : statement Graphs.graph; + f_entry : Graphs.label Types.sig0; + f_exit : Graphs.label Types.sig0 } + +(** val internal_function_rect_Type4 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod + List.list -> Nat.nat -> statement Graphs.graph -> __ -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + internal_function -> 'a1 **) +let rec internal_function_rect_Type4 h_mk_internal_function x_15456 = + let { f_labgen = f_labgen0; f_reggen = f_reggen0; f_result = f_result0; + f_params = f_params0; f_locals = f_locals0; f_stacksize = f_stacksize0; + f_graph = f_graph0; f_entry = f_entry0; f_exit = f_exit0 } = x_15456 + in + h_mk_internal_function f_labgen0 f_reggen0 f_result0 f_params0 f_locals0 + f_stacksize0 f_graph0 __ __ f_entry0 f_exit0 __ + +(** val internal_function_rect_Type5 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod + List.list -> Nat.nat -> statement Graphs.graph -> __ -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + internal_function -> 'a1 **) +let rec internal_function_rect_Type5 h_mk_internal_function x_15458 = + let { f_labgen = f_labgen0; f_reggen = f_reggen0; f_result = f_result0; + f_params = f_params0; f_locals = f_locals0; f_stacksize = f_stacksize0; + f_graph = f_graph0; f_entry = f_entry0; f_exit = f_exit0 } = x_15458 + in + h_mk_internal_function f_labgen0 f_reggen0 f_result0 f_params0 f_locals0 + f_stacksize0 f_graph0 __ __ f_entry0 f_exit0 __ + +(** val internal_function_rect_Type3 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod + List.list -> Nat.nat -> statement Graphs.graph -> __ -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + internal_function -> 'a1 **) +let rec internal_function_rect_Type3 h_mk_internal_function x_15460 = + let { f_labgen = f_labgen0; f_reggen = f_reggen0; f_result = f_result0; + f_params = f_params0; f_locals = f_locals0; f_stacksize = f_stacksize0; + f_graph = f_graph0; f_entry = f_entry0; f_exit = f_exit0 } = x_15460 + in + h_mk_internal_function f_labgen0 f_reggen0 f_result0 f_params0 f_locals0 + f_stacksize0 f_graph0 __ __ f_entry0 f_exit0 __ + +(** val internal_function_rect_Type2 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod + List.list -> Nat.nat -> statement Graphs.graph -> __ -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + internal_function -> 'a1 **) +let rec internal_function_rect_Type2 h_mk_internal_function x_15462 = + let { f_labgen = f_labgen0; f_reggen = f_reggen0; f_result = f_result0; + f_params = f_params0; f_locals = f_locals0; f_stacksize = f_stacksize0; + f_graph = f_graph0; f_entry = f_entry0; f_exit = f_exit0 } = x_15462 + in + h_mk_internal_function f_labgen0 f_reggen0 f_result0 f_params0 f_locals0 + f_stacksize0 f_graph0 __ __ f_entry0 f_exit0 __ + +(** val internal_function_rect_Type1 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod + List.list -> Nat.nat -> statement Graphs.graph -> __ -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + internal_function -> 'a1 **) +let rec internal_function_rect_Type1 h_mk_internal_function x_15464 = + let { f_labgen = f_labgen0; f_reggen = f_reggen0; f_result = f_result0; + f_params = f_params0; f_locals = f_locals0; f_stacksize = f_stacksize0; + f_graph = f_graph0; f_entry = f_entry0; f_exit = f_exit0 } = x_15464 + in + h_mk_internal_function f_labgen0 f_reggen0 f_result0 f_params0 f_locals0 + f_stacksize0 f_graph0 __ __ f_entry0 f_exit0 __ + +(** val internal_function_rect_Type0 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod + List.list -> Nat.nat -> statement Graphs.graph -> __ -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + internal_function -> 'a1 **) +let rec internal_function_rect_Type0 h_mk_internal_function x_15466 = + let { f_labgen = f_labgen0; f_reggen = f_reggen0; f_result = f_result0; + f_params = f_params0; f_locals = f_locals0; f_stacksize = f_stacksize0; + f_graph = f_graph0; f_entry = f_entry0; f_exit = f_exit0 } = x_15466 + in + h_mk_internal_function f_labgen0 f_reggen0 f_result0 f_params0 f_locals0 + f_stacksize0 f_graph0 __ __ f_entry0 f_exit0 __ + +(** val f_labgen : internal_function -> Identifiers.universe **) +let rec f_labgen xxx = + xxx.f_labgen + +(** val f_reggen : internal_function -> Identifiers.universe **) +let rec f_reggen xxx = + xxx.f_reggen + +(** val f_result : + internal_function -> (Registers.register, AST.typ) Types.prod + Types.option **) +let rec f_result xxx = + xxx.f_result + +(** val f_params : + internal_function -> (Registers.register, AST.typ) Types.prod List.list **) +let rec f_params xxx = + xxx.f_params + +(** val f_locals : + internal_function -> (Registers.register, AST.typ) Types.prod List.list **) +let rec f_locals xxx = + xxx.f_locals + +(** val f_stacksize : internal_function -> Nat.nat **) +let rec f_stacksize xxx = + xxx.f_stacksize + +(** val f_graph : internal_function -> statement Graphs.graph **) +let rec f_graph xxx = + xxx.f_graph + +(** val f_entry : internal_function -> Graphs.label Types.sig0 **) +let rec f_entry xxx = + xxx.f_entry + +(** val f_exit : internal_function -> Graphs.label Types.sig0 **) +let rec f_exit xxx = + xxx.f_exit + +(** val internal_function_inv_rect_Type4 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> Nat.nat -> + statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 -> + Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type4 hterm h1 = + let hcut = internal_function_rect_Type4 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type3 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> Nat.nat -> + statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 -> + Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type3 hterm h1 = + let hcut = internal_function_rect_Type3 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type2 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> Nat.nat -> + statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 -> + Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type2 hterm h1 = + let hcut = internal_function_rect_Type2 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type1 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> Nat.nat -> + statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 -> + Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type1 hterm h1 = + let hcut = internal_function_rect_Type1 h1 hterm in hcut __ + +(** val internal_function_inv_rect_Type0 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> Nat.nat -> + statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 -> + Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let internal_function_inv_rect_Type0 hterm h1 = + let hcut = internal_function_rect_Type0 h1 hterm in hcut __ + +(** val internal_function_jmdiscr : + internal_function -> internal_function -> __ **) +let internal_function_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { f_labgen = a0; f_reggen = a1; f_result = a2; f_params = a3; + f_locals = a4; f_stacksize = a5; f_graph = a6; f_entry = a9; f_exit = + a10 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __ __)) y + +type rTLabs_program = + (internal_function AST.fundef, AST.init_data List.list) AST.program + diff --git a/extracted/rTLabs_syntax.mli b/extracted/rTLabs_syntax.mli new file mode 100644 index 0000000..c63852c --- /dev/null +++ b/extracted/rTLabs_syntax.mli @@ -0,0 +1,423 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Types + +open AST + +open CostLabel + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open FrontEndOps + +open Order + +open Registers + +open BitVectorTrie + +open Graphs + +type statement = +| St_skip of Graphs.label +| St_cost of CostLabel.costlabel * Graphs.label +| St_const of AST.typ * Registers.register * FrontEndOps.constant + * Graphs.label +| St_op1 of AST.typ * AST.typ * FrontEndOps.unary_operation + * Registers.register * Registers.register * Graphs.label +| St_op2 of AST.typ * AST.typ * AST.typ * FrontEndOps.binary_operation + * Registers.register * Registers.register * Registers.register + * Graphs.label +| St_load of AST.typ * Registers.register * Registers.register * Graphs.label +| St_store of AST.typ * Registers.register * Registers.register + * Graphs.label +| St_call_id of AST.ident * Registers.register List.list + * Registers.register Types.option * Graphs.label +| St_call_ptr of Registers.register * Registers.register List.list + * Registers.register Types.option * Graphs.label +| St_cond of Registers.register * Graphs.label * Graphs.label +| St_return + +val statement_rect_Type4 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> Graphs.label + -> 'a1) -> 'a1 -> statement -> 'a1 + +val statement_rect_Type5 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> Graphs.label + -> 'a1) -> 'a1 -> statement -> 'a1 + +val statement_rect_Type3 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> Graphs.label + -> 'a1) -> 'a1 -> statement -> 'a1 + +val statement_rect_Type2 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> Graphs.label + -> 'a1) -> 'a1 -> statement -> 'a1 + +val statement_rect_Type1 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> Graphs.label + -> 'a1) -> 'a1 -> statement -> 'a1 + +val statement_rect_Type0 : + (Graphs.label -> 'a1) -> (CostLabel.costlabel -> Graphs.label -> 'a1) -> + (AST.typ -> Registers.register -> FrontEndOps.constant -> Graphs.label -> + 'a1) -> (AST.typ -> AST.typ -> FrontEndOps.unary_operation -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.typ -> AST.typ -> AST.typ -> FrontEndOps.binary_operation -> + Registers.register -> Registers.register -> Registers.register -> + Graphs.label -> 'a1) -> (AST.typ -> Registers.register -> + Registers.register -> Graphs.label -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> 'a1) -> + (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> 'a1) -> (Registers.register -> Graphs.label -> Graphs.label + -> 'a1) -> 'a1 -> statement -> 'a1 + +val statement_inv_rect_Type4 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> Registers.register + -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ -> AST.typ -> + FrontEndOps.binary_operation -> Registers.register -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> __ + -> 'a1) -> (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> __ -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val statement_inv_rect_Type3 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> Registers.register + -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ -> AST.typ -> + FrontEndOps.binary_operation -> Registers.register -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> __ + -> 'a1) -> (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> __ -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val statement_inv_rect_Type2 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> Registers.register + -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ -> AST.typ -> + FrontEndOps.binary_operation -> Registers.register -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> __ + -> 'a1) -> (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> __ -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val statement_inv_rect_Type1 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> Registers.register + -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ -> AST.typ -> + FrontEndOps.binary_operation -> Registers.register -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> __ + -> 'a1) -> (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> __ -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val statement_inv_rect_Type0 : + statement -> (Graphs.label -> __ -> 'a1) -> (CostLabel.costlabel -> + Graphs.label -> __ -> 'a1) -> (AST.typ -> Registers.register -> + FrontEndOps.constant -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ + -> FrontEndOps.unary_operation -> Registers.register -> Registers.register + -> Graphs.label -> __ -> 'a1) -> (AST.typ -> AST.typ -> AST.typ -> + FrontEndOps.binary_operation -> Registers.register -> Registers.register -> + Registers.register -> Graphs.label -> __ -> 'a1) -> (AST.typ -> + Registers.register -> Registers.register -> Graphs.label -> __ -> 'a1) -> + (AST.typ -> Registers.register -> Registers.register -> Graphs.label -> __ + -> 'a1) -> (AST.ident -> Registers.register List.list -> Registers.register + Types.option -> Graphs.label -> __ -> 'a1) -> (Registers.register -> + Registers.register List.list -> Registers.register Types.option -> + Graphs.label -> __ -> 'a1) -> (Registers.register -> Graphs.label -> + Graphs.label -> __ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val statement_jmdiscr : statement -> statement -> __ + +type internal_function = { f_labgen : Identifiers.universe; + f_reggen : Identifiers.universe; + f_result : (Registers.register, AST.typ) + Types.prod Types.option; + f_params : (Registers.register, AST.typ) + Types.prod List.list; + f_locals : (Registers.register, AST.typ) + Types.prod List.list; + f_stacksize : Nat.nat; + f_graph : statement Graphs.graph; + f_entry : Graphs.label Types.sig0; + f_exit : Graphs.label Types.sig0 } + +val internal_function_rect_Type4 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod List.list + -> Nat.nat -> statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 + -> Graphs.label Types.sig0 -> __ -> 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type5 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod List.list + -> Nat.nat -> statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 + -> Graphs.label Types.sig0 -> __ -> 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type3 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod List.list + -> Nat.nat -> statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 + -> Graphs.label Types.sig0 -> __ -> 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type2 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod List.list + -> Nat.nat -> statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 + -> Graphs.label Types.sig0 -> __ -> 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type1 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod List.list + -> Nat.nat -> statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 + -> Graphs.label Types.sig0 -> __ -> 'a1) -> internal_function -> 'a1 + +val internal_function_rect_Type0 : + (Identifiers.universe -> Identifiers.universe -> (Registers.register, + AST.typ) Types.prod Types.option -> (Registers.register, AST.typ) + Types.prod List.list -> (Registers.register, AST.typ) Types.prod List.list + -> Nat.nat -> statement Graphs.graph -> __ -> __ -> Graphs.label Types.sig0 + -> Graphs.label Types.sig0 -> __ -> 'a1) -> internal_function -> 'a1 + +val f_labgen : internal_function -> Identifiers.universe + +val f_reggen : internal_function -> Identifiers.universe + +val f_result : + internal_function -> (Registers.register, AST.typ) Types.prod Types.option + +val f_params : + internal_function -> (Registers.register, AST.typ) Types.prod List.list + +val f_locals : + internal_function -> (Registers.register, AST.typ) Types.prod List.list + +val f_stacksize : internal_function -> Nat.nat + +val f_graph : internal_function -> statement Graphs.graph + +val f_entry : internal_function -> Graphs.label Types.sig0 + +val f_exit : internal_function -> Graphs.label Types.sig0 + +val internal_function_inv_rect_Type4 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> Nat.nat -> statement Graphs.graph -> __ -> + __ -> Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> + 'a1) -> 'a1 + +val internal_function_inv_rect_Type3 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> Nat.nat -> statement Graphs.graph -> __ -> + __ -> Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> + 'a1) -> 'a1 + +val internal_function_inv_rect_Type2 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> Nat.nat -> statement Graphs.graph -> __ -> + __ -> Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> + 'a1) -> 'a1 + +val internal_function_inv_rect_Type1 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> Nat.nat -> statement Graphs.graph -> __ -> + __ -> Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> + 'a1) -> 'a1 + +val internal_function_inv_rect_Type0 : + internal_function -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod Types.option -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> Nat.nat -> statement Graphs.graph -> __ -> + __ -> Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> + 'a1) -> 'a1 + +val internal_function_jmdiscr : internal_function -> internal_function -> __ + +type rTLabs_program = + (internal_function AST.fundef, AST.init_data List.list) AST.program + diff --git a/extracted/rTLabs_traces.ml b/extracted/rTLabs_traces.ml new file mode 100644 index 0000000..c696aac --- /dev/null +++ b/extracted/rTLabs_traces.ml @@ -0,0 +1,1902 @@ +open Preamble + +open Deqsets_extra + +open CostSpec + +open Sets + +open Listb + +open StructuredTraces + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +open SmallstepExec + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open RTLabs_semantics + +open RTLabs_abstract + +open CostMisc + +open Executions + +open Listb_extra + +type ('o, 'i) flat_trace = ('o, 'i) __flat_trace Lazy.t +and ('o, 'i) __flat_trace = +| Ft_stop of RTLabs_semantics.state +| Ft_step of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * ('o, 'i) flat_trace + +(** val flat_trace_inv_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace + -> (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ + -> ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 **) +let flat_trace_inv_rect_Type4 x3 x4 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Ft_stop x -> h1 x __ + | Ft_step (x, x0, x1, x2) -> h2 x x0 x1 __ x2 + in + hcut __ __ + +(** val flat_trace_inv_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace + -> (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ + -> ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 **) +let flat_trace_inv_rect_Type3 x3 x4 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Ft_stop x -> h1 x __ + | Ft_step (x, x0, x1, x2) -> h2 x x0 x1 __ x2 + in + hcut __ __ + +(** val flat_trace_inv_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace + -> (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ + -> ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 **) +let flat_trace_inv_rect_Type2 x3 x4 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Ft_stop x -> h1 x __ + | Ft_step (x, x0, x1, x2) -> h2 x x0 x1 __ x2 + in + hcut __ __ + +(** val flat_trace_inv_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace + -> (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ + -> ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 **) +let flat_trace_inv_rect_Type1 x3 x4 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Ft_stop x -> h1 x __ + | Ft_step (x, x0, x1, x2) -> h2 x x0 x1 __ x2 + in + hcut __ __ + +(** val flat_trace_inv_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace + -> (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ + -> ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 **) +let flat_trace_inv_rect_Type0 x3 x4 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Ft_stop x -> h1 x __ + | Ft_step (x, x0, x1, x2) -> h2 x x0 x1 __ x2 + in + hcut __ __ + +(** val flat_trace_discr : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace + -> ('a1, 'a2) flat_trace -> __ **) +let flat_trace_discr a3 a4 x y = + Logic.eq_rect_Type2 x + (match Lazy.force + x with + | Ft_stop a0 -> Obj.magic (fun _ dH -> dH __ __) + | Ft_step (a0, a10, a20, a40) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val flat_trace_jmdiscr : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace + -> ('a1, 'a2) flat_trace -> __ **) +let flat_trace_jmdiscr a3 a4 x y = + Logic.eq_rect_Type2 x + (match Lazy.force + x with + | Ft_stop a0 -> Obj.magic (fun _ dH -> dH __ __) + | Ft_step (a0, a10, a20, a40) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val make_flat_trace : + __ -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) flat_trace **) +let rec make_flat_trace ge s = + let e = + SmallstepExec.exec_inf_aux + RTLabs_semantics.rTLabs_fullexec.SmallstepExec.es1 ge + (Obj.magic (RTLabs_semantics.eval_statement (Obj.magic ge) s)) + in + (match Lazy.force + e with + | SmallstepExec.E_stop (tr, i, s') -> + (fun _ -> lazy (Ft_step (s, tr, (Obj.magic s'), (lazy (Ft_stop + (Obj.magic s')))))) + | SmallstepExec.E_step (tr, s', e') -> + (fun _ -> lazy (Ft_step (s, tr, (Obj.magic s'), + (make_flat_trace ge (Obj.magic s'))))) + | SmallstepExec.E_wrong m -> (fun _ -> assert false (* absurd case *)) + | SmallstepExec.E_interact (o, f) -> + (fun _ -> assert false (* absurd case *))) __ + +(** val make_whole_flat_trace : + __ -> __ -> (IO.io_out, IO.io_in) flat_trace **) +let make_whole_flat_trace p s = + let ge = RTLabs_semantics.rTLabs_fullexec.SmallstepExec.make_global p in + let e = + SmallstepExec.exec_inf_aux + RTLabs_semantics.rTLabs_fullexec.SmallstepExec.es1 ge (IOMonad.Value + { Types.fst = Events.e0; Types.snd = s }) + in + (match Lazy.force + e with + | SmallstepExec.E_stop (tr, i, s') -> + (fun _ -> lazy (Ft_stop (Obj.magic s))) + | SmallstepExec.E_step (x, x0, e') -> + (fun _ -> make_flat_trace ge (Obj.magic s)) + | SmallstepExec.E_wrong m -> (fun _ -> assert false (* absurd case *)) + | SmallstepExec.E_interact (o, f) -> + (fun _ -> assert false (* absurd case *))) __ + +type will_return = +| Wr_step of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * Nat.nat * (IO.io_out, IO.io_in) flat_trace * will_return +| Wr_call of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * Nat.nat * (IO.io_out, IO.io_in) flat_trace * will_return +| Wr_ret of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * Nat.nat * (IO.io_out, IO.io_in) flat_trace * will_return +| Wr_base of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * (IO.io_out, IO.io_in) flat_trace + +(** val will_return_rect_Type4 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state + -> Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 **) +let rec will_return_rect_Type4 ge h_wr_step h_wr_call h_wr_ret h_wr_base x_1409 s x_1408 = function +| Wr_step (s0, tr, s', depth, trace, x_1411) -> + h_wr_step s0 tr s' depth __ trace __ x_1411 + (will_return_rect_Type4 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1411) +| Wr_call (s0, tr, s', depth, trace, x_1413) -> + h_wr_call s0 tr s' depth __ trace __ x_1413 + (will_return_rect_Type4 ge h_wr_step h_wr_call h_wr_ret h_wr_base (Nat.S + depth) s' trace x_1413) +| Wr_ret (s0, tr, s', depth, trace, x_1415) -> + h_wr_ret s0 tr s' depth __ trace __ x_1415 + (will_return_rect_Type4 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1415) +| Wr_base (s0, tr, s', trace) -> h_wr_base s0 tr s' __ trace __ + +(** val will_return_rect_Type3 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state + -> Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 **) +let rec will_return_rect_Type3 ge h_wr_step h_wr_call h_wr_ret h_wr_base x_1437 s x_1436 = function +| Wr_step (s0, tr, s', depth, trace, x_1439) -> + h_wr_step s0 tr s' depth __ trace __ x_1439 + (will_return_rect_Type3 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1439) +| Wr_call (s0, tr, s', depth, trace, x_1441) -> + h_wr_call s0 tr s' depth __ trace __ x_1441 + (will_return_rect_Type3 ge h_wr_step h_wr_call h_wr_ret h_wr_base (Nat.S + depth) s' trace x_1441) +| Wr_ret (s0, tr, s', depth, trace, x_1443) -> + h_wr_ret s0 tr s' depth __ trace __ x_1443 + (will_return_rect_Type3 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1443) +| Wr_base (s0, tr, s', trace) -> h_wr_base s0 tr s' __ trace __ + +(** val will_return_rect_Type2 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state + -> Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 **) +let rec will_return_rect_Type2 ge h_wr_step h_wr_call h_wr_ret h_wr_base x_1451 s x_1450 = function +| Wr_step (s0, tr, s', depth, trace, x_1453) -> + h_wr_step s0 tr s' depth __ trace __ x_1453 + (will_return_rect_Type2 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1453) +| Wr_call (s0, tr, s', depth, trace, x_1455) -> + h_wr_call s0 tr s' depth __ trace __ x_1455 + (will_return_rect_Type2 ge h_wr_step h_wr_call h_wr_ret h_wr_base (Nat.S + depth) s' trace x_1455) +| Wr_ret (s0, tr, s', depth, trace, x_1457) -> + h_wr_ret s0 tr s' depth __ trace __ x_1457 + (will_return_rect_Type2 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1457) +| Wr_base (s0, tr, s', trace) -> h_wr_base s0 tr s' __ trace __ + +(** val will_return_rect_Type1 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state + -> Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 **) +let rec will_return_rect_Type1 ge h_wr_step h_wr_call h_wr_ret h_wr_base x_1465 s x_1464 = function +| Wr_step (s0, tr, s', depth, trace, x_1467) -> + h_wr_step s0 tr s' depth __ trace __ x_1467 + (will_return_rect_Type1 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1467) +| Wr_call (s0, tr, s', depth, trace, x_1469) -> + h_wr_call s0 tr s' depth __ trace __ x_1469 + (will_return_rect_Type1 ge h_wr_step h_wr_call h_wr_ret h_wr_base (Nat.S + depth) s' trace x_1469) +| Wr_ret (s0, tr, s', depth, trace, x_1471) -> + h_wr_ret s0 tr s' depth __ trace __ x_1471 + (will_return_rect_Type1 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1471) +| Wr_base (s0, tr, s', trace) -> h_wr_base s0 tr s' __ trace __ + +(** val will_return_rect_Type0 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state + -> Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 **) +let rec will_return_rect_Type0 ge h_wr_step h_wr_call h_wr_ret h_wr_base x_1479 s x_1478 = function +| Wr_step (s0, tr, s', depth, trace, x_1481) -> + h_wr_step s0 tr s' depth __ trace __ x_1481 + (will_return_rect_Type0 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1481) +| Wr_call (s0, tr, s', depth, trace, x_1483) -> + h_wr_call s0 tr s' depth __ trace __ x_1483 + (will_return_rect_Type0 ge h_wr_step h_wr_call h_wr_ret h_wr_base (Nat.S + depth) s' trace x_1483) +| Wr_ret (s0, tr, s', depth, trace, x_1485) -> + h_wr_ret s0 tr s' depth __ trace __ x_1485 + (will_return_rect_Type0 ge h_wr_step h_wr_call h_wr_ret h_wr_base depth + s' trace x_1485) +| Wr_base (s0, tr, s', trace) -> h_wr_base s0 tr s' __ trace __ + +(** val will_return_inv_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let will_return_inv_rect_Type4 x1 x2 x3 x4 hterm h1 h2 h3 h4 = + let hcut = will_return_rect_Type4 x1 h1 h2 h3 h4 x2 x3 x4 hterm in + hcut __ __ __ __ + +(** val will_return_inv_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let will_return_inv_rect_Type3 x1 x2 x3 x4 hterm h1 h2 h3 h4 = + let hcut = will_return_rect_Type3 x1 h1 h2 h3 h4 x2 x3 x4 hterm in + hcut __ __ __ __ + +(** val will_return_inv_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let will_return_inv_rect_Type2 x1 x2 x3 x4 hterm h1 h2 h3 h4 = + let hcut = will_return_rect_Type2 x1 h1 h2 h3 h4 x2 x3 x4 hterm in + hcut __ __ __ __ + +(** val will_return_inv_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let will_return_inv_rect_Type1 x1 x2 x3 x4 hterm h1 h2 h3 h4 = + let hcut = will_return_rect_Type1 x1 h1 h2 h3 h4 x2 x3 x4 hterm in + hcut __ __ __ __ + +(** val will_return_inv_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let will_return_inv_rect_Type0 x1 x2 x3 x4 hterm h1 h2 h3 h4 = + let hcut = will_return_rect_Type0 x1 h1 h2 h3 h4 x2 x3 x4 hterm in + hcut __ __ __ __ + +(** val will_return_jmdiscr : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> will_return -> __ **) +let will_return_jmdiscr a1 a2 a3 a4 x y = + Logic.eq_rect_Type2 x + (match x with + | Wr_step (a0, a10, a20, a30, a5, a7) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __) + | Wr_call (a0, a10, a20, a30, a5, a7) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __) + | Wr_ret (a0, a10, a20, a30, a5, a7) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __) + | Wr_base (a0, a10, a20, a40) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val will_return_length : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat **) +let rec will_return_length ge d s tr = function +| Wr_step (x, x0, x1, x2, x4, t') -> + Nat.S (will_return_length ge x2 x1 x4 t') +| Wr_call (x, x0, x1, x2, x4, t') -> + Nat.S (will_return_length ge (Nat.S x2) x1 x4 t') +| Wr_ret (x, x0, x1, x2, x4, t') -> Nat.S (will_return_length ge x2 x1 x4 t') +| Wr_base (x, x0, x1, x3) -> Nat.S Nat.O + +(** val will_return_end : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state, + (IO.io_out, IO.io_in) flat_trace) Types.dPair **) +let rec will_return_end ge d s tr = function +| Wr_step (x, x0, x1, x2, x4, t') -> will_return_end ge x2 x1 x4 t' +| Wr_call (x, x0, x1, x2, x4, t') -> will_return_end ge (Nat.S x2) x1 x4 t' +| Wr_ret (x, x0, x1, x2, x4, t') -> will_return_end ge x2 x1 x4 t' +| Wr_base (x, x0, x1, tr') -> { Types.dpi1 = x1; Types.dpi2 = tr' } + +(** val will_return_call : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> will_return Types.sig0 **) +let will_return_call ge d s tr s' trace tERM = + will_return_inv_rect_Type0 ge d s (lazy (Ft_step (s, tr, s', trace))) tERM + (fun h19 h20 h21 h22 _ h24 _ h26 h27 _ _ _ _ -> assert false + (* absurd case *)) (fun h33 h34 h35 h36 _ h38 _ h40 h41 _ _ _ _ -> + Logic.eq_rect_Type0_r h36 (fun tERM0 h410 _ -> + Logic.eq_rect_Type0_r h33 (fun _ _ _ tERM1 h411 _ -> + Obj.magic flat_trace_jmdiscr ge h33 (lazy (Ft_step (h33, tr, s', + trace))) (lazy (Ft_step (h33, h34, h35, h38))) __ (fun _ -> + Logic.streicherK h33 (fun _ -> + Logic.eq_rect_Type0_r h34 (fun _ _ tERM2 h412 _ _ -> + Logic.eq_rect_Type0_r h35 (fun trace0 _ _ tERM3 h413 _ _ -> + Logic.eq_rect_Type0_r __ (fun _ tERM4 h414 _ _ -> + Logic.eq_rect_Type0_r h38 (fun _ tERM5 h415 _ -> + Logic.streicherK (lazy (Ft_step (h33, h34, h35, h38))) + (Logic.eq_rect_Type0_r (Wr_call (h33, h34, h35, h36, + h38, h40)) (fun h416 -> h40) tERM5 h415)) trace0 __ + tERM4 h414 __) __ __ tERM3 h413 __) s' trace __ __ tERM2 + h412 __) tr __ __ tERM1 h411 __))) s __ __ __ tERM0 h410 __) + d tERM h41 __) (fun h47 h48 h49 h50 _ h52 _ h54 h55 _ _ _ _ -> + assert false (* absurd case *)) (fun h61 h62 h63 _ h65 _ _ _ _ _ -> + assert false (* absurd case *)) + +(** val will_return_return : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> __ **) +let will_return_return ge d s tr s' trace tERM = + will_return_inv_rect_Type0 ge d s (lazy (Ft_step (s, tr, s', trace))) tERM + (fun h19 h20 h21 h22 _ h24 _ h26 h27 _ _ _ _ -> assert false + (* absurd case *)) (fun h33 h34 h35 h36 _ h38 _ h40 h41 _ _ _ _ -> + assert false (* absurd case *)) + (fun h47 h48 h49 h50 _ h52 _ h54 h55 _ _ _ _ -> + Logic.eq_rect_Type0_r (Nat.S h50) (fun tERM0 h550 _ -> + Logic.eq_rect_Type0_r h47 (fun _ _ _ tERM1 h551 _ -> + Obj.magic flat_trace_jmdiscr ge h47 (lazy (Ft_step (h47, tr, s', + trace))) (lazy (Ft_step (h47, h48, h49, h52))) __ (fun _ -> + Logic.streicherK h47 (fun _ -> + Logic.eq_rect_Type0_r h48 (fun _ _ tERM2 h552 _ _ -> + Logic.eq_rect_Type0_r h49 (fun trace0 _ _ tERM3 h553 _ _ -> + Logic.eq_rect_Type0_r __ (fun _ tERM4 h554 _ _ -> + Logic.eq_rect_Type0_r h52 (fun _ tERM5 h555 _ -> + Logic.streicherK (lazy (Ft_step (h47, h48, h49, h52))) + (Logic.eq_rect_Type0_r (Wr_ret (h47, h48, h49, h50, + h52, h54)) (fun h556 -> h54) tERM5 h555)) trace0 __ + tERM4 h554 __) __ __ tERM3 h553 __) s' trace __ __ tERM2 + h552 __) tr __ __ tERM1 h551 __))) s __ __ __ tERM0 h550 __) + d tERM h55 __) (Obj.magic __) + +(** val will_return_notfn : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> (__, __) Types.sum -> will_return -> will_return Types.sig0 **) +let will_return_notfn ge d s tr s' trace = function +| Types.Inl _ -> + (fun tERM -> + will_return_inv_rect_Type0 ge d s (lazy (Ft_step (s, tr, s', trace))) + tERM (fun h290 h291 h292 h293 _ h295 _ h297 h298 _ _ _ _ -> + Logic.eq_rect_Type0_r h293 (fun tERM0 h2980 _ -> + Logic.eq_rect_Type0_r h290 (fun _ _ _ tERM1 h2981 _ -> + Obj.magic flat_trace_jmdiscr ge h290 (lazy (Ft_step (h290, tr, s', + trace))) (lazy (Ft_step (h290, h291, h292, h295))) __ (fun _ -> + Logic.streicherK h290 (fun _ -> + Logic.eq_rect_Type0_r h291 (fun _ _ tERM2 h2982 _ _ -> + Logic.eq_rect_Type0_r h292 (fun trace0 _ _ tERM3 h2983 _ _ -> + Logic.eq_rect_Type0_r __ (fun _ tERM4 h2984 _ _ -> + Logic.eq_rect_Type0_r h295 (fun _ tERM5 h2985 _ -> + Logic.streicherK (lazy (Ft_step (h290, h291, h292, + h295))) + (Logic.eq_rect_Type0_r (Wr_step (h290, h291, h292, + h293, h295, h297)) (fun h2986 -> h297) tERM5 h2985)) + trace0 __ tERM4 h2984 __) __ __ tERM3 h2983 __) s' + trace __ __ tERM2 h2982 __) tr __ __ tERM1 h2981 __))) s __ + __ __ tERM0 h2980 __) d tERM h298 __) + (fun h304 h305 h306 h307 _ h309 _ h311 h312 _ _ _ _ -> assert false + (* absurd case *)) + (fun h318 h319 h320 h321 _ h323 _ h325 h326 _ _ _ _ -> assert false + (* absurd case *)) (fun h332 h333 h334 _ h336 _ _ _ _ _ -> assert false + (* absurd case *))) +| Types.Inr _ -> + (fun tERM -> + will_return_inv_rect_Type0 ge d s (lazy (Ft_step (s, tr, s', trace))) + tERM (fun h343 h344 h345 h346 _ h348 _ h350 h351 _ _ _ _ -> + Logic.eq_rect_Type0_r h346 (fun tERM0 h3510 _ -> + Logic.eq_rect_Type0_r h343 (fun _ _ _ tERM1 h3511 _ -> + Obj.magic flat_trace_jmdiscr ge h343 (lazy (Ft_step (h343, tr, s', + trace))) (lazy (Ft_step (h343, h344, h345, h348))) __ (fun _ -> + Logic.streicherK h343 (fun _ -> + Logic.eq_rect_Type0_r h344 (fun _ _ tERM2 h3512 _ _ -> + Logic.eq_rect_Type0_r h345 (fun trace0 _ _ tERM3 h3513 _ _ -> + Logic.eq_rect_Type0_r __ (fun _ tERM4 h3514 _ _ -> + Logic.eq_rect_Type0_r h348 (fun _ tERM5 h3515 _ -> + Logic.streicherK (lazy (Ft_step (h343, h344, h345, + h348))) + (Logic.eq_rect_Type0_r (Wr_step (h343, h344, h345, + h346, h348, h350)) (fun h3516 -> h350) tERM5 h3515)) + trace0 __ tERM4 h3514 __) __ __ tERM3 h3513 __) s' + trace __ __ tERM2 h3512 __) tr __ __ tERM1 h3511 __))) s __ + __ __ tERM0 h3510 __) d tERM h351 __) + (fun h357 h358 h359 h360 _ h362 _ h364 h365 _ _ _ _ -> assert false + (* absurd case *)) + (fun h371 h372 h373 h374 _ h376 _ h378 h379 _ _ _ _ -> assert false + (* absurd case *)) (fun h385 h386 h387 _ h389 _ _ _ _ _ -> assert false + (* absurd case *))) + +(** val will_return_prepend : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat -> RTLabs_semantics.state + -> (IO.io_out, IO.io_in) flat_trace -> will_return -> will_return **) +let will_return_prepend ge d1 s1 tr1 t1 d2 s2 t2 x = + will_return_rect_Type0 ge (fun s tr s' depth _ t _ t0 iH d3 s3 t3 t4 _ -> + Wr_step (s, tr, s', (Nat.plus depth (Nat.S d3)), t, (iH d3 s3 t3 t4 __))) + (fun s tr s' depth _ t _ t0 iH d3 s3 t3 t4 _ -> Wr_call (s, tr, s', + (Nat.plus depth (Nat.S d3)), t, (iH d3 s3 t3 t4 __))) + (fun s tr s' depth _ t _ t0 iH s3 s20 t3 t4 _ -> Wr_ret (s, tr, s', + (Nat.plus depth (Nat.S s3)), t, (iH s3 s20 t3 t4 __))) + (fun s tr s' _ t _ d3 s3 t3 t4 _ -> + Obj.magic Types.dPair_discr { Types.dpi1 = s'; Types.dpi2 = t } + { Types.dpi1 = s3; Types.dpi2 = t3 } __ (fun _ -> + Logic.eq_rect_Type0_r s3 (fun _ t0 _ _ -> + Logic.eq_rect_Type0_r t3 (fun _ -> + Logic.streicherK { Types.dpi1 = s3; Types.dpi2 = t3 } (Wr_ret (s, + tr, s3, d3, t3, t4))) t0 __) s' __ t __)) d1 s1 tr1 t1 d2 s2 t2 x + __ + +(** val nat_jmdiscr : Nat.nat -> Nat.nat -> __ **) +let nat_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Nat.O -> Obj.magic (fun _ dH -> dH) + | Nat.S a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val will_return_remove_call : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat -> will_return -> + RTLabs_semantics.state -> (IO.io_out, IO.io_in) flat_trace -> will_return **) +let will_return_remove_call ge d1x s1x t1x t1 d2 x s2 t2 = + will_return_rect_Type0 ge (fun s tr s' d1 _ t _ t0 iH d3 t3 s3 t4 _ -> + iH d3 + (will_return_inv_rect_Type0 ge (Nat.plus d1 (Nat.S d3)) s + (lazy (Ft_step (s, tr, s', t))) t3 + (fun h1 h2 h3 h4 _ h6 _ h8 h9 _ _ _ _ -> + Logic.eq_rect_Type0 (Nat.plus d1 (Nat.S d3)) (fun h80 h90 _ -> + Logic.eq_rect_Type0_r h1 (fun _ _ t20 _ _ h91 _ -> + Obj.magic flat_trace_jmdiscr ge h1 (lazy (Ft_step (h1, tr, s', + t))) (lazy (Ft_step (h1, h2, h3, h6))) __ (fun _ -> + Logic.streicherK h1 (fun _ -> + Logic.eq_rect_Type0_r h2 (fun _ t21 _ _ h92 _ _ -> + Logic.eq_rect_Type0_r h3 + (fun t5 t6 iH0 _ t22 _ _ h93 _ _ -> + Logic.eq_rect_Type0_r __ (fun t23 _ _ h94 _ _ -> + Logic.eq_rect_Type0_r h6 (fun t7 iH1 t24 _ _ h95 _ -> + Logic.streicherK (lazy (Ft_step (h1, h2, h3, h6))) + (Logic.eq_rect_Type0_r (Wr_step (h1, h2, h3, + (Nat.plus d1 (Nat.S d3)), h6, h80)) (fun h96 -> + h80) t24 h95)) t5 t6 iH0 t23 __ __ h94 __) __ t22 + __ __ h93 __) s' t t0 iH __ t21 __ __ h92 __) tr __ t20 + __ __ h91 __))) s __ __ t3 __ __ h90 __) h4 h8 h9 __) + (fun h15 h16 h17 h18 _ h20 _ h22 h23 _ _ _ _ -> assert false + (* absurd case *)) (fun h29 h30 h31 h32 _ h34 _ h36 h37 _ _ _ _ -> + assert false (* absurd case *)) (fun h43 h44 h45 _ h47 _ _ _ _ _ -> + assert false (* absurd case *))) s3 t4 __) + (fun s tr s' d1 _ t _ t0 iH d3 t3 s3 t4 _ -> + iH d3 + (will_return_inv_rect_Type0 ge (Nat.plus d1 (Nat.S d3)) s + (lazy (Ft_step (s, tr, s', t))) t3 + (fun h1 h2 h3 h4 _ h6 _ h8 h9 _ _ _ _ -> assert false + (* absurd case *)) (fun h15 h16 h17 h18 _ h20 _ h22 h23 _ _ _ _ -> + Logic.eq_rect_Type0 (Nat.plus d1 (Nat.S d3)) (fun h220 h230 _ -> + Logic.eq_rect_Type0_r h15 (fun _ _ t20 _ _ h231 _ -> + Obj.magic flat_trace_jmdiscr ge h15 (lazy (Ft_step (h15, tr, s', + t))) (lazy (Ft_step (h15, h16, h17, h20))) __ (fun _ -> + Logic.streicherK h15 (fun _ -> + Logic.eq_rect_Type0_r h16 (fun _ t21 _ _ h232 _ _ -> + Logic.eq_rect_Type0_r h17 + (fun t5 t6 iH0 _ t22 _ _ h233 _ _ -> + Logic.eq_rect_Type0_r __ (fun t23 _ _ h234 _ _ -> + Logic.eq_rect_Type0_r h20 (fun t7 iH1 t24 _ _ h235 _ -> + Logic.streicherK (lazy (Ft_step (h15, h16, h17, + h20))) + (Logic.eq_rect_Type0_r (Wr_call (h15, h16, h17, + (Nat.plus d1 (Nat.S d3)), h20, h220)) + (fun h236 -> h220) t24 h235)) t5 t6 iH0 t23 __ __ + h234 __) __ t22 __ __ h233 __) s' t t0 iH __ t21 __ + __ h232 __) tr __ t20 __ __ h231 __))) s __ __ t3 __ __ + h230 __) h18 h22 h23 __) + (fun h29 h30 h31 h32 _ h34 _ h36 h37 _ _ _ _ -> assert false + (* absurd case *)) (fun h43 h44 h45 _ h47 _ _ _ _ _ -> assert false + (* absurd case *))) s3 t4 __) + (fun s tr s' d1 _ t _ t0 iH d3 t3 s3 t4 _ -> + iH d3 + (will_return_inv_rect_Type0 ge (Nat.plus (Nat.S d1) (Nat.S d3)) s + (lazy (Ft_step (s, tr, s', t))) t3 + (fun h1 h2 h3 h4 _ h6 _ h8 h9 _ _ _ _ -> assert false + (* absurd case *)) (fun h15 h16 h17 h18 _ h20 _ h22 h23 _ _ _ _ -> + assert false (* absurd case *)) + (fun h29 h30 h31 h32 _ h34 _ h36 h37 _ _ _ _ -> + Obj.magic nat_jmdiscr (Nat.S (Nat.plus d1 (Nat.S d3))) (Nat.S h32) __ + (Logic.eq_rect_Type0_r h29 (fun _ _ t20 _ h370 _ _ -> + Obj.magic flat_trace_jmdiscr ge h29 (lazy (Ft_step (h29, tr, s', + t))) (lazy (Ft_step (h29, h30, h31, h34))) __ (fun _ -> + Logic.streicherK h29 (fun _ -> + Logic.eq_rect_Type0_r h30 (fun _ t21 _ h371 _ _ _ -> + Logic.eq_rect_Type0_r h31 + (fun t5 t6 iH0 _ t22 _ h372 _ _ _ -> + Logic.eq_rect_Type0_r __ (fun t23 _ h373 _ _ _ -> + Logic.eq_rect_Type0_r h34 (fun t7 iH1 t24 _ h374 _ _ -> + Logic.streicherK (lazy (Ft_step (h29, h30, h31, + h34))) (fun _ -> + Logic.eq_rect_Type0 (Nat.plus d1 (Nat.S d3)) + (fun h360 _ h375 _ -> + Logic.streicherK (Nat.S (Nat.plus d1 (Nat.S d3))) + (Logic.eq_rect_Type0_r (Wr_ret (h29, h30, h31, + (Nat.plus d1 (Nat.S d3)), h34, h360)) + (fun h376 -> h360) t24 h375)) h32 h36 __ h374 + __)) t5 t6 iH0 t23 __ h373 __ __) __ t22 __ h372 + __ __) s' t t0 iH __ t21 __ h371 __ __) tr __ t20 __ + h370 __ __))) s __ __ t3 __ h37 __ __)) + (fun h43 h44 h45 _ h47 _ _ _ _ _ -> assert false (* absurd case *))) + s3 t4 __) (fun s tr s' _ t _ d3 t3 s3 t4 _ -> + Obj.magic Types.dPair_discr { Types.dpi1 = s'; Types.dpi2 = t } + { Types.dpi1 = s3; Types.dpi2 = t4 } __ (fun _ -> + Logic.eq_rect_Type0_r s3 (fun _ t0 t20 _ _ -> + Logic.eq_rect_Type0_r t4 (fun t21 _ -> + Logic.streicherK { Types.dpi1 = s3; Types.dpi2 = t4 } + (will_return_inv_rect_Type0 ge (Nat.plus Nat.O (Nat.S d3)) s + (lazy (Ft_step (s, tr, s3, t4))) t21 + (fun h1 h2 h3 h4 _ h6 _ h8 h9 _ _ _ _ -> assert false + (* absurd case *)) + (fun h15 h16 h17 h18 _ h20 _ h22 h23 _ _ _ _ -> assert false + (* absurd case *)) + (fun h29 h30 h31 h32 _ h34 _ h36 h37 _ _ _ _ -> + Obj.magic nat_jmdiscr (Nat.S d3) (Nat.S h32) __ + (Logic.eq_rect_Type0_r h29 (fun _ _ t22 h370 _ _ -> + Obj.magic flat_trace_jmdiscr ge h29 (lazy (Ft_step (h29, + tr, s3, t4))) (lazy (Ft_step (h29, h30, h31, h34))) __ + (fun _ -> + Logic.streicherK h29 (fun _ -> + Logic.eq_rect_Type0_r h30 (fun _ t23 h371 _ _ _ -> + Logic.eq_rect_Type0_r h31 + (fun t24 _ t25 h372 _ _ _ -> + Logic.eq_rect_Type0_r __ (fun t26 h373 _ _ _ -> + Logic.eq_rect_Type0_r h34 (fun t27 h374 _ _ -> + Logic.streicherK (lazy (Ft_step (h29, h30, h31, + h34))) (fun _ -> + Logic.eq_rect_Type0_r h32 + (fun _ t28 h375 _ -> + Logic.streicherK (Nat.S h32) + (Logic.eq_rect_Type0_r (Wr_ret (h29, h30, + h31, h32, h34, h36)) (fun h376 -> h36) + t28 h375)) d3 __ t27 h374 __)) t24 t26 + h373 __ __) __ t25 h372 __ __) s3 t4 __ t23 + h371 __ __) tr __ t22 h370 __ __))) s __ __ t21 h37 + __ __)) (fun h43 h44 h45 _ h47 _ _ _ _ _ -> assert false + (* absurd case *)))) t0 t20 __) s' __ t t3 __)) d1x s1x t1x t1 + d2 x s2 t2 __ + +(** val will_return_lower : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat -> will_return **) +let will_return_lower ge d0 s0 t0 tM d' = + will_return_rect_Type0 ge (fun s tr s' d _ tr0 _ tM1 iH d'0 _ -> Wr_step + (s, tr, s', d'0, tr0, (iH d'0 __))) + (fun s tr s' d _ tr0 _ tM1 iH d'0 _ -> Wr_call (s, tr, s', d'0, tr0, + (iH (Nat.S d'0) __))) (fun s tr s' d _ tr0 _ tM1 iH clearme -> + match clearme with + | Nat.O -> (fun _ -> Wr_base (s, tr, s', tr0)) + | Nat.S d'0 -> (fun _ -> Wr_ret (s, tr, s', d'0, tr0, (iH d'0 __)))) + (fun s tr s' _ tr0 _ clearme -> + match clearme with + | Nat.O -> (fun _ -> Wr_base (s, tr, s', tr0)) + | Nat.S d'0 -> (fun _ -> assert false (* absurd case *))) d0 s0 t0 tM d' + __ + +(** val list_jmdiscr : 'a1 List.list -> 'a1 List.list -> __ **) +let list_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | List.Nil -> Obj.magic (fun _ dH -> dH) + | List.Cons (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +type 't trace_result = { new_state : RTLabs_abstract.rTLabs_ext_state; + remainder : (IO.io_out, IO.io_in) flat_trace; + new_trace : 't; terminates : __ } + +(** val trace_result_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 + trace_result -> 'a2 **) +let rec trace_result_rect_Type4 ge depth ends start full original_terminates limit h_mk_trace_result x_2020 = + let { new_state = new_state0; remainder = remainder0; new_trace = + new_trace0; terminates = terminates0 } = x_2020 + in + h_mk_trace_result new_state0 remainder0 __ new_trace0 __ terminates0 + +(** val trace_result_rect_Type5 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 + trace_result -> 'a2 **) +let rec trace_result_rect_Type5 ge depth ends start full original_terminates limit h_mk_trace_result x_2022 = + let { new_state = new_state0; remainder = remainder0; new_trace = + new_trace0; terminates = terminates0 } = x_2022 + in + h_mk_trace_result new_state0 remainder0 __ new_trace0 __ terminates0 + +(** val trace_result_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 + trace_result -> 'a2 **) +let rec trace_result_rect_Type3 ge depth ends start full original_terminates limit h_mk_trace_result x_2024 = + let { new_state = new_state0; remainder = remainder0; new_trace = + new_trace0; terminates = terminates0 } = x_2024 + in + h_mk_trace_result new_state0 remainder0 __ new_trace0 __ terminates0 + +(** val trace_result_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 + trace_result -> 'a2 **) +let rec trace_result_rect_Type2 ge depth ends start full original_terminates limit h_mk_trace_result x_2026 = + let { new_state = new_state0; remainder = remainder0; new_trace = + new_trace0; terminates = terminates0 } = x_2026 + in + h_mk_trace_result new_state0 remainder0 __ new_trace0 __ terminates0 + +(** val trace_result_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 + trace_result -> 'a2 **) +let rec trace_result_rect_Type1 ge depth ends start full original_terminates limit h_mk_trace_result x_2028 = + let { new_state = new_state0; remainder = remainder0; new_trace = + new_trace0; terminates = terminates0 } = x_2028 + in + h_mk_trace_result new_state0 remainder0 __ new_trace0 __ terminates0 + +(** val trace_result_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 + trace_result -> 'a2 **) +let rec trace_result_rect_Type0 ge depth ends start full original_terminates limit h_mk_trace_result x_2030 = + let { new_state = new_state0; remainder = remainder0; new_trace = + new_trace0; terminates = terminates0 } = x_2030 + in + h_mk_trace_result new_state0 remainder0 __ new_trace0 __ terminates0 + +(** val new_state : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> + RTLabs_abstract.rTLabs_ext_state **) +let rec new_state ge depth ends start full original_terminates limit xxx = + xxx.new_state + +(** val remainder : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> (IO.io_out, IO.io_in) + flat_trace **) +let rec remainder ge depth ends start full original_terminates limit xxx = + xxx.remainder + +(** val new_trace : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> 'a1 **) +let rec new_trace ge depth ends start full original_terminates limit xxx = + xxx.new_trace + +(** val terminates : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> __ **) +let rec terminates ge depth ends start full original_terminates limit xxx = + xxx.terminates + +(** val trace_result_inv_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + __ -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 **) +let trace_result_inv_rect_Type4 x1 x2 x3 x4 x5 x6 x8 hterm h1 = + let hcut = trace_result_rect_Type4 x1 x2 x3 x4 x5 x6 x8 h1 hterm in hcut __ + +(** val trace_result_inv_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + __ -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 **) +let trace_result_inv_rect_Type3 x1 x2 x3 x4 x5 x6 x8 hterm h1 = + let hcut = trace_result_rect_Type3 x1 x2 x3 x4 x5 x6 x8 h1 hterm in hcut __ + +(** val trace_result_inv_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + __ -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 **) +let trace_result_inv_rect_Type2 x1 x2 x3 x4 x5 x6 x8 hterm h1 = + let hcut = trace_result_rect_Type2 x1 x2 x3 x4 x5 x6 x8 h1 hterm in hcut __ + +(** val trace_result_inv_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + __ -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 **) +let trace_result_inv_rect_Type1 x1 x2 x3 x4 x5 x6 x8 hterm h1 = + let hcut = trace_result_rect_Type1 x1 x2 x3 x4 x5 x6 x8 h1 hterm in hcut __ + +(** val trace_result_inv_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + __ -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 **) +let trace_result_inv_rect_Type0 x1 x2 x3 x4 x5 x6 x8 hterm h1 = + let hcut = trace_result_rect_Type0 x1 x2 x3 x4 x5 x6 x8 h1 hterm in hcut __ + +(** val trace_result_jmdiscr : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> Nat.nat -> 'a1 trace_result -> 'a1 trace_result -> __ **) +let trace_result_jmdiscr a1 a2 a3 a4 a5 a6 a8 x y = + Logic.eq_rect_Type2 x + (let { new_state = a0; remainder = a10; new_trace = a30; terminates = + a50 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +type 't sub_trace_result = { ends : StructuredTraces.trace_ends_with_ret; + trace_res : 't trace_result } + +(** val sub_trace_result_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 **) +let rec sub_trace_result_rect_Type4 ge depth start full original_terminates limit h_mk_sub_trace_result x_2048 = + let { ends = ends0; trace_res = trace_res0 } = x_2048 in + h_mk_sub_trace_result ends0 trace_res0 + +(** val sub_trace_result_rect_Type5 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 **) +let rec sub_trace_result_rect_Type5 ge depth start full original_terminates limit h_mk_sub_trace_result x_2050 = + let { ends = ends0; trace_res = trace_res0 } = x_2050 in + h_mk_sub_trace_result ends0 trace_res0 + +(** val sub_trace_result_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 **) +let rec sub_trace_result_rect_Type3 ge depth start full original_terminates limit h_mk_sub_trace_result x_2052 = + let { ends = ends0; trace_res = trace_res0 } = x_2052 in + h_mk_sub_trace_result ends0 trace_res0 + +(** val sub_trace_result_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 **) +let rec sub_trace_result_rect_Type2 ge depth start full original_terminates limit h_mk_sub_trace_result x_2054 = + let { ends = ends0; trace_res = trace_res0 } = x_2054 in + h_mk_sub_trace_result ends0 trace_res0 + +(** val sub_trace_result_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 **) +let rec sub_trace_result_rect_Type1 ge depth start full original_terminates limit h_mk_sub_trace_result x_2056 = + let { ends = ends0; trace_res = trace_res0 } = x_2056 in + h_mk_sub_trace_result ends0 trace_res0 + +(** val sub_trace_result_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 **) +let rec sub_trace_result_rect_Type0 ge depth start full original_terminates limit h_mk_sub_trace_result x_2058 = + let { ends = ends0; trace_res = trace_res0 } = x_2058 in + h_mk_sub_trace_result ends0 trace_res0 + +(** val ends : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> StructuredTraces.trace_ends_with_ret **) +let rec ends ge depth start full original_terminates limit xxx = + xxx.ends + +(** val trace_res : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> 'a1 trace_result **) +let rec trace_res ge depth start full original_terminates limit xxx = + xxx.trace_res + +(** val sub_trace_result_inv_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 **) +let sub_trace_result_inv_rect_Type4 x1 x2 x3 x4 x5 x7 hterm h1 = + let hcut = sub_trace_result_rect_Type4 x1 x2 x3 x4 x5 x7 h1 hterm in + hcut __ + +(** val sub_trace_result_inv_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 **) +let sub_trace_result_inv_rect_Type3 x1 x2 x3 x4 x5 x7 hterm h1 = + let hcut = sub_trace_result_rect_Type3 x1 x2 x3 x4 x5 x7 h1 hterm in + hcut __ + +(** val sub_trace_result_inv_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 **) +let sub_trace_result_inv_rect_Type2 x1 x2 x3 x4 x5 x7 hterm h1 = + let hcut = sub_trace_result_rect_Type2 x1 x2 x3 x4 x5 x7 h1 hterm in + hcut __ + +(** val sub_trace_result_inv_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 **) +let sub_trace_result_inv_rect_Type1 x1 x2 x3 x4 x5 x7 hterm h1 = + let hcut = sub_trace_result_rect_Type1 x1 x2 x3 x4 x5 x7 h1 hterm in + hcut __ + +(** val sub_trace_result_inv_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 **) +let sub_trace_result_inv_rect_Type0 x1 x2 x3 x4 x5 x7 hterm h1 = + let hcut = sub_trace_result_rect_Type0 x1 x2 x3 x4 x5 x7 h1 hterm in + hcut __ + +(** val sub_trace_result_discr : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> 'a1 sub_trace_result -> __ **) +let sub_trace_result_discr a1 a2 a3 a4 a5 a7 x y = + Logic.eq_rect_Type2 x + (let { ends = a0; trace_res = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val sub_trace_result_jmdiscr : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> 'a1 sub_trace_result -> __ **) +let sub_trace_result_jmdiscr a1 a2 a3 a4 a5 a7 x y = + Logic.eq_rect_Type2 x + (let { ends = a0; trace_res = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val replace_trace : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret + -> RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state + -> (IO.io_out, IO.io_in) flat_trace -> (IO.io_out, IO.io_in) flat_trace + -> will_return -> will_return -> Nat.nat -> Nat.nat -> 'a1 trace_result + -> 'a2 -> 'a2 trace_result **) +let replace_trace ge d e s1 s2 t1 t2 tM1 tM2 l1 l2 r trace = + { new_state = r.new_state; remainder = r.remainder; new_trace = trace; + terminates = + ((match e with + | StructuredTraces.Ends_with_ret -> + Logic.eq_rect_Type0 + (will_return_end ge d s1.RTLabs_abstract.ras_state t1 tM1) + (fun clearme -> + let { new_state = x; remainder = x0; new_trace = x1; terminates = + x2 } = clearme + in + (match d with + | Nat.O -> Obj.magic __ + | Nat.S d' -> + (fun tM10 tM20 ns rem _ t1NS _ clearme0 -> + let tMa = Obj.magic clearme0 in Obj.magic tMa)) tM1 tM2 x x0 + __ x1 __ x2) + (will_return_end ge d s2.RTLabs_abstract.ras_state t2 tM2) + | StructuredTraces.Doesnt_end_with_ret -> + Logic.eq_rect_Type0 + (will_return_end ge d s1.RTLabs_abstract.ras_state t1 tM1) + (fun clearme -> + let { new_state = ns; remainder = rem; new_trace = t1NS; + terminates = clearme0 } = clearme + in + let tMa = Obj.magic clearme0 in Obj.magic tMa) + (will_return_end ge d s2.RTLabs_abstract.ras_state t2 tM2)) r) } + +(** val replace_sub_trace : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> will_return -> Nat.nat + -> Nat.nat -> 'a1 sub_trace_result -> 'a2 -> 'a2 sub_trace_result **) +let replace_sub_trace ge d s1 s2 t1 t2 tM1 tM2 l1 l2 r trace = + { ends = r.ends; trace_res = + (replace_trace ge d r.ends s1 s2 t1 t2 tM1 tM2 l1 l2 r.trace_res trace) } + +(** val make_label_return : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + StructuredTraces.trace_label_return trace_result **) +let rec make_label_return ge depth s trace tERMINATES tIME = + (match tIME with + | Nat.O -> (fun _ -> assert false (* absurd case *)) + | Nat.S tIME0 -> + (fun _ -> + let r = make_label_label ge depth s trace tERMINATES tIME0 in + (match r.ends with + | StructuredTraces.Ends_with_ret -> + (fun r0 -> + replace_trace ge depth StructuredTraces.Ends_with_ret s s trace + trace tERMINATES tERMINATES + (will_return_length ge depth s.RTLabs_abstract.ras_state trace + tERMINATES) + (will_return_length ge depth s.RTLabs_abstract.ras_state trace + tERMINATES) r0 (StructuredTraces.Tlr_base ((Obj.magic s), + (Obj.magic r0.new_state), r0.new_trace))) + | StructuredTraces.Doesnt_end_with_ret -> + (fun r0 -> + let r' = + make_label_return ge depth r0.new_state r0.remainder + (Types.pi1 (Obj.magic r0.terminates)) tIME0 + in + replace_trace ge depth StructuredTraces.Ends_with_ret + r0.new_state s r0.remainder trace + (Types.pi1 (Obj.magic r0.terminates)) tERMINATES + (will_return_length ge depth + r0.new_state.RTLabs_abstract.ras_state r0.remainder + (Types.pi1 (Obj.magic r0.terminates))) + (will_return_length ge depth s.RTLabs_abstract.ras_state trace + tERMINATES) r' (StructuredTraces.Tlr_step ((Obj.magic s), + (Obj.magic r0.new_state), (Obj.magic r'.new_state), + r0.new_trace, r'.new_trace)))) r.trace_res)) __ +(** val make_label_label : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + StructuredTraces.trace_label_label sub_trace_result **) +and make_label_label ge depth s trace tERMINATES tIME = + (match tIME with + | Nat.O -> (fun _ -> assert false (* absurd case *)) + | Nat.S tIME0 -> + (fun _ -> + let r = make_any_label ge depth s trace tERMINATES tIME0 in + replace_sub_trace ge depth s s trace trace tERMINATES tERMINATES + (will_return_length ge depth s.RTLabs_abstract.ras_state trace + tERMINATES) + (will_return_length ge depth s.RTLabs_abstract.ras_state trace + tERMINATES) r (StructuredTraces.Tll_base (r.ends, (Obj.magic s), + (Obj.magic r.trace_res.new_state), r.trace_res.new_trace)))) __ +(** val make_any_label : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + StructuredTraces.trace_any_label sub_trace_result **) +and make_any_label ge depth s0 trace tERMINATES tIME = + (match tIME with + | Nat.O -> (fun _ -> assert false (* absurd case *)) + | Nat.S tIME0 -> + (fun _ -> + (let { RTLabs_abstract.ras_state = s; RTLabs_abstract.ras_fn_stack = + stk } = s0 + in + (fun trace0 _ tM _ -> + (match Lazy.force + trace0 with + | Ft_stop st -> + (fun _ _ tERMINATES0 _ -> assert false (* absurd case *)) + | Ft_step (start, tr, next, trace') -> + (fun _ _ tERMINATES0 _ -> + let start' = { RTLabs_abstract.ras_state = start; + RTLabs_abstract.ras_fn_stack = stk } + in + let next' = RTLabs_abstract.next_state ge start' next tr in + (match RTLabs_abstract.rTLabs_classify start with + | StructuredTraces.Cl_return -> + (fun _ -> { ends = StructuredTraces.Ends_with_ret; trace_res = + { new_state = next'; remainder = trace'; new_trace = + (StructuredTraces.Tal_base_return ((Obj.magic start'), + (Obj.magic next'))); terminates = + (will_return_return ge depth start tr next trace' + tERMINATES0) } }) + | StructuredTraces.Cl_jump -> + (fun _ -> { ends = StructuredTraces.Doesnt_end_with_ret; + trace_res = { new_state = next'; remainder = trace'; + new_trace = (StructuredTraces.Tal_base_not_return + ((Obj.magic start'), (Obj.magic next'))); terminates = + (Obj.magic + (will_return_notfn ge depth start tr next trace' + (Types.Inr __) tERMINATES0)) } }) + | StructuredTraces.Cl_call -> + (fun _ -> + let r = + make_label_return ge (Nat.S depth) next' trace' + (Types.pi1 + (will_return_call ge depth start tr next trace' + tERMINATES0)) tIME0 + in + (match RTLabs_abstract.rTLabs_cost + r.new_state.RTLabs_abstract.ras_state with + | Bool.True -> + (fun _ -> { ends = StructuredTraces.Doesnt_end_with_ret; + trace_res = { new_state = r.new_state; remainder = + r.remainder; new_trace = + (StructuredTraces.Tal_base_call ((Obj.magic start'), + (Obj.magic next'), (Obj.magic r.new_state), + r.new_trace)); terminates = + (let tMr = Obj.magic r.terminates in Obj.magic tMr) } }) + | Bool.False -> + (fun _ -> + let r' = + make_any_label ge depth r.new_state r.remainder + (Types.pi1 (Obj.magic r.terminates)) tIME0 + in + replace_sub_trace ge depth r.new_state start' + r.remainder (lazy (Ft_step (start, tr, next, + trace'))) (Types.pi1 (Obj.magic r.terminates)) + tERMINATES0 + (will_return_length ge depth + r.new_state.RTLabs_abstract.ras_state r.remainder + (Types.pi1 (Obj.magic r.terminates))) + (will_return_length ge depth start (lazy (Ft_step + (start, tr, next, trace'))) tERMINATES0) r' + (StructuredTraces.Tal_step_call (r'.ends, + (Obj.magic start'), (Obj.magic next'), + (Obj.magic r.new_state), + (Obj.magic r'.trace_res.new_state), r.new_trace, + r'.trace_res.new_trace)))) __) + | StructuredTraces.Cl_tailcall -> + (fun _ -> assert false (* absurd case *)) + | StructuredTraces.Cl_other -> + (fun _ -> + (match RTLabs_abstract.rTLabs_cost next with + | Bool.True -> + (fun _ -> { ends = StructuredTraces.Doesnt_end_with_ret; + trace_res = { new_state = next'; remainder = trace'; + new_trace = (StructuredTraces.Tal_base_not_return + ((Obj.magic start'), (Obj.magic next'))); terminates = + (Obj.magic + (will_return_notfn ge depth start tr next trace' + (Types.Inl __) tERMINATES0)) } }) + | Bool.False -> + (fun _ -> + let r = + make_any_label ge depth next' trace' + (Types.pi1 + (will_return_notfn ge depth start tr next trace' + (Types.Inl __) tERMINATES0)) tIME0 + in + replace_sub_trace ge depth next' start' trace' + (lazy (Ft_step (start, tr, next, trace'))) + (Types.pi1 + (will_return_notfn ge depth start tr next trace' + (Types.Inl __) tERMINATES0)) tERMINATES0 + (will_return_length ge depth + next'.RTLabs_abstract.ras_state trace' + (Types.pi1 + (will_return_notfn ge depth start tr next trace' + (Types.Inl __) tERMINATES0))) + (will_return_length ge depth start (lazy (Ft_step + (start, tr, next, trace'))) tERMINATES0) r + (StructuredTraces.Tal_step_default (r.ends, + (Obj.magic start'), (Obj.magic next'), + (Obj.magic r.trace_res.new_state), + r.trace_res.new_trace)))) __)) __)) __ __ tM __)) + trace __ tERMINATES __)) __ + +(** val make_label_return' : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> + StructuredTraces.trace_label_return trace_result **) +let rec make_label_return' ge depth s trace tERMINATES = + make_label_return ge depth s trace tERMINATES + (Nat.plus (Nat.S (Nat.S Nat.O)) + (Nat.times (Nat.S (Nat.S (Nat.S Nat.O))) + (will_return_length ge depth s.RTLabs_abstract.ras_state trace + tERMINATES))) + +(** val actual_successor : + RTLabs_semantics.state -> Graphs.label Types.option **) +let actual_successor = function +| RTLabs_semantics.State (f, fs, m) -> Types.Some f.RTLabs_semantics.next +| RTLabs_semantics.Callstate (x, x0, x1, x2, fs, x3) -> + (match fs with + | List.Nil -> Types.None + | List.Cons (f, x4) -> Types.Some f.RTLabs_semantics.next) +| RTLabs_semantics.Returnstate (x, x0, x1, x2) -> Types.None +| RTLabs_semantics.Finalstate x -> Types.None + +(** val steps_for_statement : RTLabs_syntax.statement -> Nat.nat **) +let steps_for_statement s = + Nat.S + (match s with + | RTLabs_syntax.St_skip x -> Nat.O + | RTLabs_syntax.St_cost (x, x0) -> Nat.O + | RTLabs_syntax.St_const (x, x0, x1, x2) -> Nat.O + | RTLabs_syntax.St_op1 (x, x0, x1, x2, x3, x4) -> Nat.O + | RTLabs_syntax.St_op2 (x, x0, x1, x2, x3, x4, x5, x6) -> Nat.O + | RTLabs_syntax.St_load (x, x0, x1, x2) -> Nat.O + | RTLabs_syntax.St_store (x, x0, x1, x2) -> Nat.O + | RTLabs_syntax.St_call_id (x, x0, x1, x2) -> Nat.S Nat.O + | RTLabs_syntax.St_call_ptr (x, x0, x1, x2) -> Nat.S Nat.O + | RTLabs_syntax.St_cond (x, x0, x1) -> Nat.O + | RTLabs_syntax.St_return -> Nat.S Nat.O) + +type remainder_ok = +| Mk_remainder_ok + +(** val remainder_ok_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 **) +let rec remainder_ok_rect_Type4 ge s t h_mk_remainder_ok = function +| Mk_remainder_ok -> h_mk_remainder_ok __ __ __ __ + +(** val remainder_ok_rect_Type5 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 **) +let rec remainder_ok_rect_Type5 ge s t h_mk_remainder_ok = function +| Mk_remainder_ok -> h_mk_remainder_ok __ __ __ __ + +(** val remainder_ok_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 **) +let rec remainder_ok_rect_Type3 ge s t h_mk_remainder_ok = function +| Mk_remainder_ok -> h_mk_remainder_ok __ __ __ __ + +(** val remainder_ok_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 **) +let rec remainder_ok_rect_Type2 ge s t h_mk_remainder_ok = function +| Mk_remainder_ok -> h_mk_remainder_ok __ __ __ __ + +(** val remainder_ok_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 **) +let rec remainder_ok_rect_Type1 ge s t h_mk_remainder_ok = function +| Mk_remainder_ok -> h_mk_remainder_ok __ __ __ __ + +(** val remainder_ok_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 **) +let rec remainder_ok_rect_Type0 ge s t h_mk_remainder_ok = function +| Mk_remainder_ok -> h_mk_remainder_ok __ __ __ __ + +(** val remainder_ok_inv_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let remainder_ok_inv_rect_Type4 x1 x2 x3 hterm h1 = + let hcut = remainder_ok_rect_Type4 x1 x2 x3 h1 hterm in hcut __ + +(** val remainder_ok_inv_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let remainder_ok_inv_rect_Type3 x1 x2 x3 hterm h1 = + let hcut = remainder_ok_rect_Type3 x1 x2 x3 h1 hterm in hcut __ + +(** val remainder_ok_inv_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let remainder_ok_inv_rect_Type2 x1 x2 x3 hterm h1 = + let hcut = remainder_ok_rect_Type2 x1 x2 x3 h1 hterm in hcut __ + +(** val remainder_ok_inv_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let remainder_ok_inv_rect_Type1 x1 x2 x3 hterm h1 = + let hcut = remainder_ok_rect_Type1 x1 x2 x3 h1 hterm in hcut __ + +(** val remainder_ok_inv_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let remainder_ok_inv_rect_Type0 x1 x2 x3 hterm h1 = + let hcut = remainder_ok_rect_Type0 x1 x2 x3 h1 hterm in hcut __ + +(** val remainder_ok_discr : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> remainder_ok -> __ **) +let remainder_ok_discr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (let Mk_remainder_ok = x in Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val remainder_ok_jmdiscr : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> remainder_ok -> __ **) +let remainder_ok_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (let Mk_remainder_ok = x in Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val init_state_is : + RTLabs_syntax.rTLabs_program -> RTLabs_semantics.state -> + (Pointers.block, __) Types.dPair **) +let init_state_is p s = + RTLabs_semantics.bind_ok (Globalenvs.init_mem (fun x -> x) p) (fun x -> + let main = p.AST.prog_main in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingSymbol), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, main)), List.Nil)))) + (Globalenvs.find_symbol (RTLabs_semantics.make_global p) main))) + (fun b -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, main)), List.Nil)))) + (Globalenvs.find_funct_ptr (RTLabs_semantics.make_global p) b))) + (fun f -> + Obj.magic (Errors.OK (RTLabs_semantics.Callstate (main, f, + List.Nil, Types.None, List.Nil, x))))))) s (fun m _ _ -> + RTLabs_semantics.bind_ok + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.MissingSymbol), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, p.AST.prog_main)), List.Nil)))) + (Globalenvs.find_symbol (RTLabs_semantics.make_global p) + p.AST.prog_main)) (fun x -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, p.AST.prog_main)), List.Nil)))) + (Globalenvs.find_funct_ptr (RTLabs_semantics.make_global p) x))) + (fun f -> + Obj.magic (Errors.OK (RTLabs_semantics.Callstate (p.AST.prog_main, + f, List.Nil, Types.None, List.Nil, m)))))) s (fun b _ _ -> + RTLabs_semantics.bind_ok + (Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.BadFunction), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, p.AST.prog_main)), List.Nil)))) + (Globalenvs.find_funct_ptr (RTLabs_semantics.make_global p) b)) + (fun x -> Errors.OK (RTLabs_semantics.Callstate (p.AST.prog_main, x, + List.Nil, Types.None, List.Nil, m))) s (fun f _ _ -> + Obj.magic Errors.res_discr (Errors.OK (RTLabs_semantics.Callstate + (p.AST.prog_main, f, List.Nil, Types.None, List.Nil, m))) + (Errors.OK s) __ (fun _ -> + Logic.eq_rect_Type0 (RTLabs_semantics.Callstate (p.AST.prog_main, + f, List.Nil, Types.None, List.Nil, m)) (fun _ -> + Logic.streicherK (Errors.OK (RTLabs_semantics.Callstate + (p.AST.prog_main, f, List.Nil, Types.None, List.Nil, m))) + { Types.dpi1 = b; Types.dpi2 = __ }) s __)))) + +(** val ras_state_initial : + RTLabs_syntax.rTLabs_program -> RTLabs_semantics.state -> + RTLabs_abstract.rTLabs_ext_state **) +let ras_state_initial p s = + { RTLabs_abstract.ras_state = s; RTLabs_abstract.ras_fn_stack = (List.Cons + ((init_state_is p s).Types.dpi1, List.Nil)) } + +(** val deprop_execute : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> Events.trace Types.sig0 **) +let rec deprop_execute ge s s' = + (match RTLabs_semantics.eval_statement ge s with + | IOMonad.Interact (x, x0) -> (fun _ -> assert false (* absurd case *)) + | IOMonad.Value ts -> (fun _ -> ts.Types.fst) + | IOMonad.Wrong x -> (fun _ -> assert false (* absurd case *))) __ + +(** val deprop_as_execute : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> Events.trace Types.sig0 **) +let rec deprop_as_execute ge s s' = + deprop_execute ge s.RTLabs_abstract.ras_state s'.RTLabs_abstract.ras_state + +type ('o, 'i) partial_flat_trace = +| Pft_base of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state +| Pft_step of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * RTLabs_semantics.state * ('o, 'i) partial_flat_trace + +(** val partial_flat_trace_rect_Type4 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 **) +let rec partial_flat_trace_rect_Type4 ge h_pft_base h_pft_step x_2393 x_2392 = function +| Pft_base (s, tr, s') -> h_pft_base s tr s' __ +| Pft_step (s, tr, s', s'', x_2396) -> + h_pft_step s tr s' s'' __ x_2396 + (partial_flat_trace_rect_Type4 ge h_pft_base h_pft_step s' s'' x_2396) + +(** val partial_flat_trace_rect_Type3 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 **) +let rec partial_flat_trace_rect_Type3 ge h_pft_base h_pft_step x_2409 x_2408 = function +| Pft_base (s, tr, s') -> h_pft_base s tr s' __ +| Pft_step (s, tr, s', s'', x_2412) -> + h_pft_step s tr s' s'' __ x_2412 + (partial_flat_trace_rect_Type3 ge h_pft_base h_pft_step s' s'' x_2412) + +(** val partial_flat_trace_rect_Type2 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 **) +let rec partial_flat_trace_rect_Type2 ge h_pft_base h_pft_step x_2417 x_2416 = function +| Pft_base (s, tr, s') -> h_pft_base s tr s' __ +| Pft_step (s, tr, s', s'', x_2420) -> + h_pft_step s tr s' s'' __ x_2420 + (partial_flat_trace_rect_Type2 ge h_pft_base h_pft_step s' s'' x_2420) + +(** val partial_flat_trace_rect_Type1 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 **) +let rec partial_flat_trace_rect_Type1 ge h_pft_base h_pft_step x_2425 x_2424 = function +| Pft_base (s, tr, s') -> h_pft_base s tr s' __ +| Pft_step (s, tr, s', s'', x_2428) -> + h_pft_step s tr s' s'' __ x_2428 + (partial_flat_trace_rect_Type1 ge h_pft_base h_pft_step s' s'' x_2428) + +(** val partial_flat_trace_rect_Type0 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 **) +let rec partial_flat_trace_rect_Type0 ge h_pft_base h_pft_step x_2433 x_2432 = function +| Pft_base (s, tr, s') -> h_pft_base s tr s' __ +| Pft_step (s, tr, s', s'', x_2436) -> + h_pft_step s tr s' s'' __ x_2436 + (partial_flat_trace_rect_Type0 ge h_pft_base h_pft_step s' s'' x_2436) + +(** val partial_flat_trace_inv_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> + __ -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let partial_flat_trace_inv_rect_Type4 x3 x4 x5 hterm h1 h2 = + let hcut = partial_flat_trace_rect_Type4 x3 h1 h2 x4 x5 hterm in + hcut __ __ __ + +(** val partial_flat_trace_inv_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> + __ -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let partial_flat_trace_inv_rect_Type3 x3 x4 x5 hterm h1 h2 = + let hcut = partial_flat_trace_rect_Type3 x3 h1 h2 x4 x5 hterm in + hcut __ __ __ + +(** val partial_flat_trace_inv_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> + __ -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let partial_flat_trace_inv_rect_Type2 x3 x4 x5 hterm h1 h2 = + let hcut = partial_flat_trace_rect_Type2 x3 h1 h2 x4 x5 hterm in + hcut __ __ __ + +(** val partial_flat_trace_inv_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> + __ -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let partial_flat_trace_inv_rect_Type1 x3 x4 x5 hterm h1 h2 = + let hcut = partial_flat_trace_rect_Type1 x3 h1 h2 x4 x5 hterm in + hcut __ __ __ + +(** val partial_flat_trace_inv_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> + __ -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 **) +let partial_flat_trace_inv_rect_Type0 x3 x4 x5 hterm h1 h2 = + let hcut = partial_flat_trace_rect_Type0 x3 h1 h2 x4 x5 hterm in + hcut __ __ __ + +(** val partial_flat_trace_jmdiscr : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> ('a1, 'a2) partial_flat_trace -> __ **) +let partial_flat_trace_jmdiscr a3 a4 a5 x y = + Logic.eq_rect_Type2 x + (match x with + | Pft_base (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Pft_step (a0, a10, a20, a30, a50) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __)) y + +(** val append_partial_flat_trace : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> ('a1, 'a2) + partial_flat_trace -> ('a1, 'a2) partial_flat_trace **) +let rec append_partial_flat_trace ge s1 s2 s3 = function +| Pft_base (s, tr, s') -> (fun x -> Pft_step (s, tr, s', s3, x)) +| Pft_step (s, tr, s', s'', tr') -> + (fun tr2 -> Pft_step (s, tr, s', s3, + (append_partial_flat_trace ge s' s'' s3 tr' tr2))) + +(** val partial_to_flat_trace : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> ('a1, 'a2) flat_trace -> ('a1, 'a2) + flat_trace **) +let rec partial_to_flat_trace ge s1 s2 = function +| Pft_base (s, tr0, s') -> (fun x -> lazy (Ft_step (s, tr0, s', x))) +| Pft_step (s, tr0, s', s'', tr') -> + (fun tr'' -> lazy (Ft_step (s, tr0, s', + (partial_to_flat_trace ge s' s'' tr' tr'')))) + +(** val flat_trace_of_label_return : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> StructuredTraces.trace_label_return + -> (IO.io_out, IO.io_in) partial_flat_trace **) +let rec flat_trace_of_label_return ge s s' = function +| StructuredTraces.Tlr_base (s1, s2, tll) -> + flat_trace_of_label_label ge StructuredTraces.Ends_with_ret (Obj.magic s1) + (Obj.magic s2) tll +| StructuredTraces.Tlr_step (s1, s2, s3, tll, tlr) -> + append_partial_flat_trace ge (Obj.magic s1).RTLabs_abstract.ras_state + (Obj.magic s2).RTLabs_abstract.ras_state + (Obj.magic s3).RTLabs_abstract.ras_state + (flat_trace_of_label_label ge StructuredTraces.Doesnt_end_with_ret + (Obj.magic s1) (Obj.magic s2) tll) + (flat_trace_of_label_return ge (Obj.magic s2) (Obj.magic s3) tlr) +(** val flat_trace_of_label_label : + RTLabs_semantics.genv -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_label_label -> (IO.io_out, IO.io_in) + partial_flat_trace **) +and flat_trace_of_label_label ge ends0 s s' = function +| StructuredTraces.Tll_base (e, s1, s2, tal) -> + flat_trace_of_any_label ge e (Obj.magic s1) (Obj.magic s2) tal +(** val flat_trace_of_any_label : + RTLabs_semantics.genv -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_any_label -> (IO.io_out, IO.io_in) + partial_flat_trace **) +and flat_trace_of_any_label ge ends0 s s' = function +| StructuredTraces.Tal_base_not_return (s1, s2) -> + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s2) in + Pft_base ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s2).RTLabs_abstract.ras_state) +| StructuredTraces.Tal_base_return (s1, s2) -> + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s2) in + Pft_base ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s2).RTLabs_abstract.ras_state) +| StructuredTraces.Tal_base_call (s1, s2, s3, tlr) -> + let suffix' = + flat_trace_of_label_return ge (Obj.magic s2) (Obj.magic s3) tlr + in + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s2) in + Pft_step ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s2).RTLabs_abstract.ras_state, + (Obj.magic s3).RTLabs_abstract.ras_state, suffix') +| StructuredTraces.Tal_base_tailcall (s1, s2, s3, tlr) -> + assert false (* absurd case *) +| StructuredTraces.Tal_step_call (ends1, s1, s2, s3, s4, tlr, tal) -> + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s2) in + Pft_step ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s2).RTLabs_abstract.ras_state, + (Obj.magic s4).RTLabs_abstract.ras_state, + (append_partial_flat_trace ge (Obj.magic s2).RTLabs_abstract.ras_state + (Obj.magic s3).RTLabs_abstract.ras_state + (Obj.magic s4).RTLabs_abstract.ras_state + (flat_trace_of_label_return ge (Obj.magic s2) (Obj.magic s3) tlr) + (flat_trace_of_any_label ge ends1 (Obj.magic s3) (Obj.magic s4) tal))) +| StructuredTraces.Tal_step_default (ends1, s1, s2, s3, tal) -> + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s2) in + Pft_step ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s2).RTLabs_abstract.ras_state, + (Obj.magic s3).RTLabs_abstract.ras_state, + (flat_trace_of_any_label ge ends1 (Obj.magic s2) (Obj.magic s3) tal)) + +(** val flat_trace_of_any_call : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + Events.trace -> StructuredTraces.trace_any_call -> (IO.io_out, IO.io_in) + partial_flat_trace **) +let rec flat_trace_of_any_call ge s s' s'' et tr = + (match tr with + | StructuredTraces.Tac_base s1 -> + (fun _ -> Pft_base ((Obj.magic s1).RTLabs_abstract.ras_state, et, + s''.RTLabs_abstract.ras_state)) + | StructuredTraces.Tac_step_call (s1, s2, s3, s4, tlr, tac) -> + (fun _ -> + let et0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s4) in + Pft_step ((Obj.magic s1).RTLabs_abstract.ras_state, et0, + (Obj.magic s4).RTLabs_abstract.ras_state, + s''.RTLabs_abstract.ras_state, + (append_partial_flat_trace ge (Obj.magic s4).RTLabs_abstract.ras_state + (Obj.magic s2).RTLabs_abstract.ras_state + s''.RTLabs_abstract.ras_state + (flat_trace_of_label_return ge (Obj.magic s4) (Obj.magic s2) tlr) + (flat_trace_of_any_call ge (Obj.magic s2) (Obj.magic s3) s'' et tac)))) + | StructuredTraces.Tac_step_default (s1, s2, s3, tal) -> + (fun _ -> + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s3) in + Pft_step ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s3).RTLabs_abstract.ras_state, + s''.RTLabs_abstract.ras_state, + (flat_trace_of_any_call ge (Obj.magic s3) (Obj.magic s2) s'' et tal)))) + __ + +(** val flat_trace_of_label_call : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + Events.trace -> StructuredTraces.trace_label_call -> (IO.io_out, + IO.io_in) partial_flat_trace **) +let rec flat_trace_of_label_call ge s s' s'' et tr = + (let StructuredTraces.Tlc_base (s1, s2, tac) = tr in + (fun _ -> + flat_trace_of_any_call ge (Obj.magic s1) (Obj.magic s2) s'' et tac)) __ + +(** val flat_trace_of_label_diverges : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_label_diverges -> (IO.io_out, IO.io_in) flat_trace **) +let rec flat_trace_of_label_diverges ge s tr = + match Lazy.force + tr with + | StructuredTraces.Tld_step (sx, sy, tll, tld) -> + (let { RTLabs_abstract.ras_state = sy'; RTLabs_abstract.ras_fn_stack = + stk } = Obj.magic sy + in + (fun tll0 -> + (match flat_trace_of_label_label ge StructuredTraces.Doesnt_end_with_ret + (Obj.magic sx) { RTLabs_abstract.ras_state = sy'; + RTLabs_abstract.ras_fn_stack = stk } tll0 with + | Pft_base (s1, tr0, s2) -> + (fun _ tld0 -> lazy (Ft_step (s1, tr0, s2, + (flat_trace_of_label_diverges ge { RTLabs_abstract.ras_state = s2; + RTLabs_abstract.ras_fn_stack = stk } tld0)))) + | Pft_step (s1, et, s2, s3, tr') -> + (fun _ tld0 -> lazy (Ft_step (s1, et, s2, + (add_partial_flat_trace ge s2 { RTLabs_abstract.ras_state = s3; + RTLabs_abstract.ras_fn_stack = stk } tr' tld0))))) __)) tll tld + | StructuredTraces.Tld_base (s1, s2, s3, tlc, tld) -> + (let { RTLabs_abstract.ras_state = s3'; RTLabs_abstract.ras_fn_stack = + stk } = Obj.magic s3 + in + (fun _ -> + let tr0 = + deprop_as_execute ge (Obj.magic s2) { RTLabs_abstract.ras_state = s3'; + RTLabs_abstract.ras_fn_stack = stk } + in + (match flat_trace_of_label_call ge (Obj.magic s1) (Obj.magic s2) + { RTLabs_abstract.ras_state = s3'; + RTLabs_abstract.ras_fn_stack = stk } tr0 tlc with + | Pft_base (s10, tr1, s20) -> + (fun _ tld0 -> lazy (Ft_step (s10, tr1, s20, + (flat_trace_of_label_diverges ge { RTLabs_abstract.ras_state = s20; + RTLabs_abstract.ras_fn_stack = stk } tld0)))) + | Pft_step (s10, et, s20, s30, tr') -> + (fun _ tld0 -> lazy (Ft_step (s10, et, s20, + (add_partial_flat_trace ge s20 { RTLabs_abstract.ras_state = s30; + RTLabs_abstract.ras_fn_stack = stk } tr' tld0))))) __)) __ tld +(** val add_partial_flat_trace : + RTLabs_semantics.genv -> RTLabs_semantics.state -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) + partial_flat_trace -> StructuredTraces.trace_label_diverges -> + (IO.io_out, IO.io_in) flat_trace **) +and add_partial_flat_trace ge s s' = + let { RTLabs_abstract.ras_state = sx; RTLabs_abstract.ras_fn_stack = + stk } = s' + in + (fun ptr -> + (match ptr with + | Pft_base (s0, tr, s'0) -> + (fun _ tr0 -> lazy (Ft_step (s0, tr, s'0, + (flat_trace_of_label_diverges ge { RTLabs_abstract.ras_state = s'0; + RTLabs_abstract.ras_fn_stack = stk } tr0)))) + | Pft_step (s1, et, s2, s3, tr') -> + (fun _ tr -> lazy (Ft_step (s1, et, s2, + (add_partial_flat_trace ge s2 { RTLabs_abstract.ras_state = s3; + RTLabs_abstract.ras_fn_stack = stk } tr' tr))))) __) + +(** val flat_trace_of_whole_program : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_whole_program -> (IO.io_out, IO.io_in) flat_trace **) +let rec flat_trace_of_whole_program ge s = function +| StructuredTraces.Twp_terminating (s1, s2, sf, tlr) -> + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s2) in + lazy (Ft_step ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s2).RTLabs_abstract.ras_state, + (partial_to_flat_trace ge (Obj.magic s2).RTLabs_abstract.ras_state + (Obj.magic sf).RTLabs_abstract.ras_state + (flat_trace_of_label_return ge (Obj.magic s2) (Obj.magic sf) tlr) + (lazy (Ft_stop (Obj.magic sf).RTLabs_abstract.ras_state))))) +| StructuredTraces.Twp_diverges (s1, s2, tld) -> + let tr0 = deprop_as_execute ge (Obj.magic s1) (Obj.magic s2) in + lazy (Ft_step ((Obj.magic s1).RTLabs_abstract.ras_state, tr0, + (Obj.magic s2).RTLabs_abstract.ras_state, + (flat_trace_of_label_diverges ge (Obj.magic s2) tld))) + +(** val state_fn : + RTLabs_semantics.genv -> __ -> Pointers.block Types.option **) +let state_fn ge s = + match (Obj.magic s).RTLabs_abstract.ras_fn_stack with + | List.Nil -> Types.None + | List.Cons (h, t) -> + (match (Obj.magic s).RTLabs_abstract.ras_state with + | RTLabs_semantics.State (x, x0, x1) -> Types.Some h + | RTLabs_semantics.Callstate (x, x0, x1, x2, x3, x4) -> + (match t with + | List.Nil -> Types.None + | List.Cons (h', x5) -> Types.Some h') + | RTLabs_semantics.Returnstate (x, x0, x1, x2) -> Types.Some h + | RTLabs_semantics.Finalstate x -> Types.Some h) + +(** val option_jmdiscr : 'a1 Types.option -> 'a1 Types.option -> __ **) +let option_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Types.None -> Obj.magic (fun _ dH -> dH) + | Types.Some a0 -> Obj.magic (fun _ dH -> dH __)) y + diff --git a/extracted/rTLabs_traces.mli b/extracted/rTLabs_traces.mli new file mode 100644 index 0000000..4d2e622 --- /dev/null +++ b/extracted/rTLabs_traces.mli @@ -0,0 +1,840 @@ +open Preamble + +open Deqsets_extra + +open CostSpec + +open Sets + +open Listb + +open StructuredTraces + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open FrontEndOps + +open RTLabs_syntax + +open SmallstepExec + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Globalenvs + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Errors + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open RTLabs_semantics + +open RTLabs_abstract + +open CostMisc + +open Executions + +open Listb_extra + +type ('o, 'i) flat_trace = ('o, 'i) __flat_trace Lazy.t +and ('o, 'i) __flat_trace = +| Ft_stop of RTLabs_semantics.state +| Ft_step of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * ('o, 'i) flat_trace + +val flat_trace_inv_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace -> + (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 + +val flat_trace_inv_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace -> + (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 + +val flat_trace_inv_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace -> + (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 + +val flat_trace_inv_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace -> + (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 + +val flat_trace_inv_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace -> + (RTLabs_semantics.state -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) flat_trace -> __ -> __ -> 'a3) -> 'a3 + +val flat_trace_discr : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace -> + ('a1, 'a2) flat_trace -> __ + +val flat_trace_jmdiscr : + RTLabs_semantics.genv -> RTLabs_semantics.state -> ('a1, 'a2) flat_trace -> + ('a1, 'a2) flat_trace -> __ + +val make_flat_trace : + __ -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) flat_trace + +val make_whole_flat_trace : __ -> __ -> (IO.io_out, IO.io_in) flat_trace + +type will_return = +| Wr_step of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * Nat.nat * (IO.io_out, IO.io_in) flat_trace * will_return +| Wr_call of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * Nat.nat * (IO.io_out, IO.io_in) flat_trace * will_return +| Wr_ret of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * Nat.nat * (IO.io_out, IO.io_in) flat_trace * will_return +| Wr_base of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * (IO.io_out, IO.io_in) flat_trace + +val will_return_rect_Type4 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 + +val will_return_rect_Type3 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 + +val will_return_rect_Type2 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 + +val will_return_rect_Type1 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 + +val will_return_rect_Type0 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> 'a1 -> 'a1) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> 'a1 -> 'a1) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> will_return -> + 'a1 -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + 'a1) -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) + flat_trace -> will_return -> 'a1 + +val will_return_inv_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) + -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> + __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val will_return_inv_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) + -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> + __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val will_return_inv_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) + -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> + __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val will_return_inv_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) + -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> + __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val will_return_inv_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, + IO.io_in) flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) + -> __ -> __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) + flat_trace -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> + __ -> __ -> __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> Nat.nat -> __ -> (IO.io_out, IO.io_in) flat_trace + -> __ -> will_return -> (__ -> __ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + __ -> 'a1) -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> (IO.io_out, IO.io_in) flat_trace -> __ -> + __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val will_return_jmdiscr : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> will_return -> __ + +val will_return_length : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat + +val will_return_end : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> (RTLabs_semantics.state, (IO.io_out, + IO.io_in) flat_trace) Types.dPair + +val will_return_call : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> will_return Types.sig0 + +val will_return_return : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> __ + +val will_return_notfn : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> (IO.io_out, IO.io_in) flat_trace -> (__, __) + Types.sum -> will_return -> will_return Types.sig0 + +val will_return_prepend : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat -> RTLabs_semantics.state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> will_return + +val nat_jmdiscr : Nat.nat -> Nat.nat -> __ + +val will_return_remove_call : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat -> will_return -> + RTLabs_semantics.state -> (IO.io_out, IO.io_in) flat_trace -> will_return + +val will_return_lower : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_semantics.state -> (IO.io_out, + IO.io_in) flat_trace -> will_return -> Nat.nat -> will_return + +val list_jmdiscr : 'a1 List.list -> 'a1 List.list -> __ + +type 't trace_result = { new_state : RTLabs_abstract.rTLabs_ext_state; + remainder : (IO.io_out, IO.io_in) flat_trace; + new_trace : 't; terminates : __ } + +val trace_result_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 trace_result + -> 'a2 + +val trace_result_rect_Type5 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 trace_result + -> 'a2 + +val trace_result_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 trace_result + -> 'a2 + +val trace_result_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 trace_result + -> 'a2 + +val trace_result_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 trace_result + -> 'a2 + +val trace_result_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> __ -> 'a1 -> __ -> __ -> 'a2) -> 'a1 trace_result + -> 'a2 + +val new_state : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> + RTLabs_abstract.rTLabs_ext_state + +val remainder : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> (IO.io_out, IO.io_in) + flat_trace + +val new_trace : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> 'a1 + +val terminates : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> __ + +val trace_result_inv_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> __ + -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 + +val trace_result_inv_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> __ + -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 + +val trace_result_inv_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> __ + -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 + +val trace_result_inv_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> __ + -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 + +val trace_result_inv_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> + (RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> __ + -> 'a1 -> __ -> __ -> __ -> 'a2) -> 'a2 + +val trace_result_jmdiscr : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> Nat.nat -> 'a1 trace_result -> 'a1 trace_result -> __ + +type 't sub_trace_result = { ends : StructuredTraces.trace_ends_with_ret; + trace_res : 't trace_result } + +val sub_trace_result_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 + +val sub_trace_result_rect_Type5 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 + +val sub_trace_result_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 + +val sub_trace_result_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 + +val sub_trace_result_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 + +val sub_trace_result_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + (StructuredTraces.trace_ends_with_ret -> 'a1 trace_result -> 'a2) -> 'a1 + sub_trace_result -> 'a2 + +val ends : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> StructuredTraces.trace_ends_with_ret + +val trace_res : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> 'a1 trace_result + +val sub_trace_result_inv_rect_Type4 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 + +val sub_trace_result_inv_rect_Type3 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 + +val sub_trace_result_inv_rect_Type2 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 + +val sub_trace_result_inv_rect_Type1 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 + +val sub_trace_result_inv_rect_Type0 : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> (StructuredTraces.trace_ends_with_ret -> 'a1 + trace_result -> __ -> 'a2) -> 'a2 + +val sub_trace_result_discr : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> 'a1 sub_trace_result -> __ + +val sub_trace_result_jmdiscr : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> 'a1 + sub_trace_result -> 'a1 sub_trace_result -> __ + +val replace_trace : + RTLabs_semantics.genv -> Nat.nat -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> (IO.io_out, IO.io_in) flat_trace -> + will_return -> will_return -> Nat.nat -> Nat.nat -> 'a1 trace_result -> 'a2 + -> 'a2 trace_result + +val replace_sub_trace : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) flat_trace -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> will_return -> Nat.nat + -> Nat.nat -> 'a1 sub_trace_result -> 'a2 -> 'a2 sub_trace_result + +val make_any_label : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + StructuredTraces.trace_any_label sub_trace_result + +val make_label_label : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + StructuredTraces.trace_label_label sub_trace_result + +val make_label_return : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> Nat.nat -> + StructuredTraces.trace_label_return trace_result + +val make_label_return' : + RTLabs_semantics.genv -> Nat.nat -> RTLabs_abstract.rTLabs_ext_state -> + (IO.io_out, IO.io_in) flat_trace -> will_return -> + StructuredTraces.trace_label_return trace_result + +val actual_successor : RTLabs_semantics.state -> Graphs.label Types.option + +val steps_for_statement : RTLabs_syntax.statement -> Nat.nat + +type remainder_ok = +| Mk_remainder_ok + +val remainder_ok_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 + +val remainder_ok_rect_Type5 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 + +val remainder_ok_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 + +val remainder_ok_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 + +val remainder_ok_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 + +val remainder_ok_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> (__ -> __ -> __ -> __ -> 'a1) -> remainder_ok -> + 'a1 + +val remainder_ok_inv_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val remainder_ok_inv_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val remainder_ok_inv_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val remainder_ok_inv_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val remainder_ok_inv_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> (__ -> __ -> __ -> __ -> __ -> 'a1) + -> 'a1 + +val remainder_ok_discr : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> remainder_ok -> __ + +val remainder_ok_jmdiscr : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, + IO.io_in) flat_trace -> remainder_ok -> remainder_ok -> __ + +val init_state_is : + RTLabs_syntax.rTLabs_program -> RTLabs_semantics.state -> (Pointers.block, + __) Types.dPair + +val ras_state_initial : + RTLabs_syntax.rTLabs_program -> RTLabs_semantics.state -> + RTLabs_abstract.rTLabs_ext_state + +val deprop_execute : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> Events.trace Types.sig0 + +val deprop_as_execute : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> Events.trace Types.sig0 + +type ('o, 'i) partial_flat_trace = +| Pft_base of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state +| Pft_step of RTLabs_semantics.state * Events.trace * RTLabs_semantics.state + * RTLabs_semantics.state * ('o, 'i) partial_flat_trace + +val partial_flat_trace_rect_Type4 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 + +val partial_flat_trace_rect_Type3 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 + +val partial_flat_trace_rect_Type2 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 + +val partial_flat_trace_rect_Type1 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 + +val partial_flat_trace_rect_Type0 : + RTLabs_semantics.genv -> (RTLabs_semantics.state -> Events.trace -> + RTLabs_semantics.state -> __ -> 'a3) -> (RTLabs_semantics.state -> + Events.trace -> RTLabs_semantics.state -> RTLabs_semantics.state -> __ -> + ('a1, 'a2) partial_flat_trace -> 'a3 -> 'a3) -> RTLabs_semantics.state -> + RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> 'a3 + +val partial_flat_trace_inv_rect_Type4 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> __ + -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 + +val partial_flat_trace_inv_rect_Type3 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> __ + -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 + +val partial_flat_trace_inv_rect_Type2 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> __ + -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 + +val partial_flat_trace_inv_rect_Type1 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> __ + -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 + +val partial_flat_trace_inv_rect_Type0 : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> (RTLabs_semantics.state -> Events.trace + -> RTLabs_semantics.state -> __ -> __ -> __ -> __ -> 'a3) -> + (RTLabs_semantics.state -> Events.trace -> RTLabs_semantics.state -> + RTLabs_semantics.state -> __ -> ('a1, 'a2) partial_flat_trace -> (__ -> __ + -> __ -> 'a3) -> __ -> __ -> __ -> 'a3) -> 'a3 + +val partial_flat_trace_jmdiscr : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> ('a1, 'a2) partial_flat_trace -> __ + +val append_partial_flat_trace : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> RTLabs_semantics.state -> ('a1, 'a2) partial_flat_trace -> ('a1, 'a2) + partial_flat_trace -> ('a1, 'a2) partial_flat_trace + +val partial_to_flat_trace : + RTLabs_semantics.genv -> RTLabs_semantics.state -> RTLabs_semantics.state + -> ('a1, 'a2) partial_flat_trace -> ('a1, 'a2) flat_trace -> ('a1, 'a2) + flat_trace + +val flat_trace_of_any_label : + RTLabs_semantics.genv -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_any_label -> (IO.io_out, IO.io_in) + partial_flat_trace + +val flat_trace_of_label_label : + RTLabs_semantics.genv -> StructuredTraces.trace_ends_with_ret -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_label_label -> (IO.io_out, IO.io_in) + partial_flat_trace + +val flat_trace_of_label_return : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> StructuredTraces.trace_label_return -> + (IO.io_out, IO.io_in) partial_flat_trace + +val flat_trace_of_any_call : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + Events.trace -> StructuredTraces.trace_any_call -> (IO.io_out, IO.io_in) + partial_flat_trace + +val flat_trace_of_label_call : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + RTLabs_abstract.rTLabs_ext_state -> RTLabs_abstract.rTLabs_ext_state -> + Events.trace -> StructuredTraces.trace_label_call -> (IO.io_out, IO.io_in) + partial_flat_trace + +val add_partial_flat_trace : + RTLabs_semantics.genv -> RTLabs_semantics.state -> + RTLabs_abstract.rTLabs_ext_state -> (IO.io_out, IO.io_in) + partial_flat_trace -> StructuredTraces.trace_label_diverges -> (IO.io_out, + IO.io_in) flat_trace + +val flat_trace_of_label_diverges : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_label_diverges -> (IO.io_out, IO.io_in) flat_trace + +val flat_trace_of_whole_program : + RTLabs_semantics.genv -> RTLabs_abstract.rTLabs_ext_state -> + StructuredTraces.trace_whole_program -> (IO.io_out, IO.io_in) flat_trace + +val state_fn : RTLabs_semantics.genv -> __ -> Pointers.block Types.option + +val option_jmdiscr : 'a1 Types.option -> 'a1 Types.option -> __ + diff --git a/extracted/registerSet.ml b/extracted/registerSet.ml new file mode 100644 index 0000000..a8be682 --- /dev/null +++ b/extracted/registerSet.ml @@ -0,0 +1,321 @@ +open Preamble + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open BitVector + +open Arithmetic + +open Jmeq + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open I8051 + +open Order + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Registers + +type register_set = { rs_empty : __; rs_singleton : (I8051.register -> __); + rs_fold : (__ -> (I8051.register -> __ -> __) -> __ -> + __ -> __); + rs_insert : (I8051.register -> __ -> __); + rs_exists : (I8051.register -> __ -> Bool.bool); + rs_union : (__ -> __ -> __); + rs_subset : (__ -> __ -> Bool.bool); + rs_to_list : (__ -> I8051.register List.list); + rs_from_list : (I8051.register List.list -> __) } + +(** val register_set_rect_Type4 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> + __) -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register + -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ + -> I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) + -> register_set -> 'a1 **) +let rec register_set_rect_Type4 h_mk_register_set x_18453 = + let { rs_empty = rs_empty0; rs_singleton = rs_singleton0; rs_fold = + rs_fold0; rs_insert = rs_insert0; rs_exists = rs_exists0; rs_union = + rs_union0; rs_subset = rs_subset0; rs_to_list = rs_to_list0; + rs_from_list = rs_from_list0 } = x_18453 + in + h_mk_register_set __ rs_empty0 rs_singleton0 rs_fold0 rs_insert0 rs_exists0 + rs_union0 rs_subset0 rs_to_list0 rs_from_list0 + +(** val register_set_rect_Type5 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> + __) -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register + -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ + -> I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) + -> register_set -> 'a1 **) +let rec register_set_rect_Type5 h_mk_register_set x_18455 = + let { rs_empty = rs_empty0; rs_singleton = rs_singleton0; rs_fold = + rs_fold0; rs_insert = rs_insert0; rs_exists = rs_exists0; rs_union = + rs_union0; rs_subset = rs_subset0; rs_to_list = rs_to_list0; + rs_from_list = rs_from_list0 } = x_18455 + in + h_mk_register_set __ rs_empty0 rs_singleton0 rs_fold0 rs_insert0 rs_exists0 + rs_union0 rs_subset0 rs_to_list0 rs_from_list0 + +(** val register_set_rect_Type3 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> + __) -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register + -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ + -> I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) + -> register_set -> 'a1 **) +let rec register_set_rect_Type3 h_mk_register_set x_18457 = + let { rs_empty = rs_empty0; rs_singleton = rs_singleton0; rs_fold = + rs_fold0; rs_insert = rs_insert0; rs_exists = rs_exists0; rs_union = + rs_union0; rs_subset = rs_subset0; rs_to_list = rs_to_list0; + rs_from_list = rs_from_list0 } = x_18457 + in + h_mk_register_set __ rs_empty0 rs_singleton0 rs_fold0 rs_insert0 rs_exists0 + rs_union0 rs_subset0 rs_to_list0 rs_from_list0 + +(** val register_set_rect_Type2 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> + __) -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register + -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ + -> I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) + -> register_set -> 'a1 **) +let rec register_set_rect_Type2 h_mk_register_set x_18459 = + let { rs_empty = rs_empty0; rs_singleton = rs_singleton0; rs_fold = + rs_fold0; rs_insert = rs_insert0; rs_exists = rs_exists0; rs_union = + rs_union0; rs_subset = rs_subset0; rs_to_list = rs_to_list0; + rs_from_list = rs_from_list0 } = x_18459 + in + h_mk_register_set __ rs_empty0 rs_singleton0 rs_fold0 rs_insert0 rs_exists0 + rs_union0 rs_subset0 rs_to_list0 rs_from_list0 + +(** val register_set_rect_Type1 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> + __) -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register + -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ + -> I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) + -> register_set -> 'a1 **) +let rec register_set_rect_Type1 h_mk_register_set x_18461 = + let { rs_empty = rs_empty0; rs_singleton = rs_singleton0; rs_fold = + rs_fold0; rs_insert = rs_insert0; rs_exists = rs_exists0; rs_union = + rs_union0; rs_subset = rs_subset0; rs_to_list = rs_to_list0; + rs_from_list = rs_from_list0 } = x_18461 + in + h_mk_register_set __ rs_empty0 rs_singleton0 rs_fold0 rs_insert0 rs_exists0 + rs_union0 rs_subset0 rs_to_list0 rs_from_list0 + +(** val register_set_rect_Type0 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> + __) -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register + -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ + -> I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) + -> register_set -> 'a1 **) +let rec register_set_rect_Type0 h_mk_register_set x_18463 = + let { rs_empty = rs_empty0; rs_singleton = rs_singleton0; rs_fold = + rs_fold0; rs_insert = rs_insert0; rs_exists = rs_exists0; rs_union = + rs_union0; rs_subset = rs_subset0; rs_to_list = rs_to_list0; + rs_from_list = rs_from_list0 } = x_18463 + in + h_mk_register_set __ rs_empty0 rs_singleton0 rs_fold0 rs_insert0 rs_exists0 + rs_union0 rs_subset0 rs_to_list0 rs_from_list0 + +type rs_set = __ + +(** val rs_empty : register_set -> __ **) +let rec rs_empty xxx = + xxx.rs_empty + +(** val rs_singleton : register_set -> I8051.register -> __ **) +let rec rs_singleton xxx = + xxx.rs_singleton + +(** val rs_fold0 : + register_set -> (I8051.register -> 'a1 -> 'a1) -> __ -> 'a1 -> 'a1 **) +let rec rs_fold0 xxx x_18487 x_18488 x_18489 = + (let { rs_empty = x0; rs_singleton = x1; rs_fold = yyy; rs_insert = x2; + rs_exists = x3; rs_union = x4; rs_subset = x5; rs_to_list = x6; + rs_from_list = x7 } = xxx + in + Obj.magic yyy) __ x_18487 x_18488 x_18489 + +(** val rs_insert : register_set -> I8051.register -> __ -> __ **) +let rec rs_insert xxx = + xxx.rs_insert + +(** val rs_exists : register_set -> I8051.register -> __ -> Bool.bool **) +let rec rs_exists xxx = + xxx.rs_exists + +(** val rs_union : register_set -> __ -> __ -> __ **) +let rec rs_union xxx = + xxx.rs_union + +(** val rs_subset : register_set -> __ -> __ -> Bool.bool **) +let rec rs_subset xxx = + xxx.rs_subset + +(** val rs_to_list : register_set -> __ -> I8051.register List.list **) +let rec rs_to_list xxx = + xxx.rs_to_list + +(** val rs_from_list : register_set -> I8051.register List.list -> __ **) +let rec rs_from_list xxx = + xxx.rs_from_list + +(** val register_set_inv_rect_Type4 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ + -> __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ + -> __ -> Bool.bool) -> (__ -> I8051.register List.list) -> + (I8051.register List.list -> __) -> __ -> 'a1) -> 'a1 **) +let register_set_inv_rect_Type4 hterm h1 = + let hcut = register_set_rect_Type4 h1 hterm in hcut __ + +(** val register_set_inv_rect_Type3 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ + -> __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ + -> __ -> Bool.bool) -> (__ -> I8051.register List.list) -> + (I8051.register List.list -> __) -> __ -> 'a1) -> 'a1 **) +let register_set_inv_rect_Type3 hterm h1 = + let hcut = register_set_rect_Type3 h1 hterm in hcut __ + +(** val register_set_inv_rect_Type2 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ + -> __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ + -> __ -> Bool.bool) -> (__ -> I8051.register List.list) -> + (I8051.register List.list -> __) -> __ -> 'a1) -> 'a1 **) +let register_set_inv_rect_Type2 hterm h1 = + let hcut = register_set_rect_Type2 h1 hterm in hcut __ + +(** val register_set_inv_rect_Type1 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ + -> __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ + -> __ -> Bool.bool) -> (__ -> I8051.register List.list) -> + (I8051.register List.list -> __) -> __ -> 'a1) -> 'a1 **) +let register_set_inv_rect_Type1 hterm h1 = + let hcut = register_set_rect_Type1 h1 hterm in hcut __ + +(** val register_set_inv_rect_Type0 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ + -> __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ + -> __ -> Bool.bool) -> (__ -> I8051.register List.list) -> + (I8051.register List.list -> __) -> __ -> 'a1) -> 'a1 **) +let register_set_inv_rect_Type0 hterm h1 = + let hcut = register_set_rect_Type0 h1 hterm in hcut __ + +(** val register_set_jmdiscr : register_set -> register_set -> __ **) +let register_set_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { rs_empty = a1; rs_singleton = a2; rs_fold = a3; rs_insert = a4; + rs_exists = a5; rs_union = a6; rs_subset = a7; rs_to_list = a8; + rs_from_list = a9 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __)) y + +(** val rs_list_set_empty : I8051.register List.list **) +let rs_list_set_empty = + List.Nil + +(** val rs_list_set_singleton : + I8051.register -> I8051.register List.list **) +let rs_list_set_singleton r = + List.Cons (r, List.Nil) + +(** val rs_list_set_fold : + (I8051.register -> 'a1 -> 'a1) -> I8051.register List.list -> 'a1 -> 'a1 **) +let rs_list_set_fold f l a = + List.foldr f a l + +(** val rs_list_set_insert : + I8051.register -> I8051.register List.list -> I8051.register List.list **) +let rs_list_set_insert r s = + match Util.member I8051.eq_Register r s with + | Bool.True -> List.Cons (r, s) + | Bool.False -> s + +(** val rs_list_set_exists : + I8051.register -> I8051.register List.list -> Bool.bool **) +let rs_list_set_exists r s = + Util.member I8051.eq_Register r s + +(** val rs_list_set_union : + I8051.register List.list -> I8051.register List.list -> I8051.register + List.list **) +let rs_list_set_union r s = + Util.nub_by I8051.eq_Register (List.append r s) + +(** val rs_list_set_subset : + I8051.register List.list -> I8051.register List.list -> Bool.bool **) +let rs_list_set_subset r s = + Util.forall (fun x -> Util.member I8051.eq_Register x s) r + +(** val rs_list_set_from_list : + I8051.register List.list -> I8051.register List.list **) +let rs_list_set_from_list r = + Util.nub_by I8051.eq_Register r + +(** val register_list_set : register_set **) +let register_list_set = + { rs_empty = (Obj.magic rs_list_set_empty); rs_singleton = + (Obj.magic rs_list_set_singleton); rs_fold = + (Obj.magic (fun _ -> rs_list_set_fold)); rs_insert = + (Obj.magic rs_list_set_insert); rs_exists = + (Obj.magic rs_list_set_exists); rs_union = (Obj.magic rs_list_set_union); + rs_subset = (Obj.magic rs_list_set_subset); rs_to_list = (fun x -> + Obj.magic x); rs_from_list = (Obj.magic rs_list_set_from_list) } + diff --git a/extracted/registerSet.mli b/extracted/registerSet.mli new file mode 100644 index 0000000..4debf70 --- /dev/null +++ b/extracted/registerSet.mli @@ -0,0 +1,207 @@ +open Preamble + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Russell + +open Types + +open List + +open Util + +open FoldStuff + +open BitVector + +open Arithmetic + +open Jmeq + +open Bool + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Nat + +open I8051 + +open Order + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Registers + +type register_set = { rs_empty : __; rs_singleton : (I8051.register -> __); + rs_fold : (__ -> (I8051.register -> __ -> __) -> __ -> + __ -> __); + rs_insert : (I8051.register -> __ -> __); + rs_exists : (I8051.register -> __ -> Bool.bool); + rs_union : (__ -> __ -> __); + rs_subset : (__ -> __ -> Bool.bool); + rs_to_list : (__ -> I8051.register List.list); + rs_from_list : (I8051.register List.list -> __) } + +val register_set_rect_Type4 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> __) + -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register -> __ + -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ -> + I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) -> + register_set -> 'a1 + +val register_set_rect_Type5 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> __) + -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register -> __ + -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ -> + I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) -> + register_set -> 'a1 + +val register_set_rect_Type3 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> __) + -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register -> __ + -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ -> + I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) -> + register_set -> 'a1 + +val register_set_rect_Type2 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> __) + -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register -> __ + -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ -> + I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) -> + register_set -> 'a1 + +val register_set_rect_Type1 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> __) + -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register -> __ + -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ -> + I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) -> + register_set -> 'a1 + +val register_set_rect_Type0 : + (__ -> __ -> (I8051.register -> __) -> (__ -> (I8051.register -> __ -> __) + -> __ -> __ -> __) -> (I8051.register -> __ -> __) -> (I8051.register -> __ + -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ -> Bool.bool) -> (__ -> + I8051.register List.list) -> (I8051.register List.list -> __) -> 'a1) -> + register_set -> 'a1 + +type rs_set + +val rs_empty : register_set -> __ + +val rs_singleton : register_set -> I8051.register -> __ + +val rs_fold0 : + register_set -> (I8051.register -> 'a1 -> 'a1) -> __ -> 'a1 -> 'a1 + +val rs_insert : register_set -> I8051.register -> __ -> __ + +val rs_exists : register_set -> I8051.register -> __ -> Bool.bool + +val rs_union : register_set -> __ -> __ -> __ + +val rs_subset : register_set -> __ -> __ -> Bool.bool + +val rs_to_list : register_set -> __ -> I8051.register List.list + +val rs_from_list : register_set -> I8051.register List.list -> __ + +val register_set_inv_rect_Type4 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ -> + __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ + -> Bool.bool) -> (__ -> I8051.register List.list) -> (I8051.register + List.list -> __) -> __ -> 'a1) -> 'a1 + +val register_set_inv_rect_Type3 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ -> + __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ + -> Bool.bool) -> (__ -> I8051.register List.list) -> (I8051.register + List.list -> __) -> __ -> 'a1) -> 'a1 + +val register_set_inv_rect_Type2 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ -> + __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ + -> Bool.bool) -> (__ -> I8051.register List.list) -> (I8051.register + List.list -> __) -> __ -> 'a1) -> 'a1 + +val register_set_inv_rect_Type1 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ -> + __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ + -> Bool.bool) -> (__ -> I8051.register List.list) -> (I8051.register + List.list -> __) -> __ -> 'a1) -> 'a1 + +val register_set_inv_rect_Type0 : + register_set -> (__ -> __ -> (I8051.register -> __) -> (__ -> + (I8051.register -> __ -> __) -> __ -> __ -> __) -> (I8051.register -> __ -> + __) -> (I8051.register -> __ -> Bool.bool) -> (__ -> __ -> __) -> (__ -> __ + -> Bool.bool) -> (__ -> I8051.register List.list) -> (I8051.register + List.list -> __) -> __ -> 'a1) -> 'a1 + +val register_set_jmdiscr : register_set -> register_set -> __ + +val rs_list_set_empty : I8051.register List.list + +val rs_list_set_singleton : I8051.register -> I8051.register List.list + +val rs_list_set_fold : + (I8051.register -> 'a1 -> 'a1) -> I8051.register List.list -> 'a1 -> 'a1 + +val rs_list_set_insert : + I8051.register -> I8051.register List.list -> I8051.register List.list + +val rs_list_set_exists : + I8051.register -> I8051.register List.list -> Bool.bool + +val rs_list_set_union : + I8051.register List.list -> I8051.register List.list -> I8051.register + List.list + +val rs_list_set_subset : + I8051.register List.list -> I8051.register List.list -> Bool.bool + +val rs_list_set_from_list : + I8051.register List.list -> I8051.register List.list + +val register_list_set : register_set + diff --git a/extracted/registers.ml b/extracted/registers.ml new file mode 100644 index 0000000..0ad8818 --- /dev/null +++ b/extracted/registers.ml @@ -0,0 +1,64 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open Order + +type register = PreIdentifiers.identifier + +(** val register_eq : register -> register -> (__, __) Types.sum **) +let register_eq = + Identifiers.identifier_eq PreIdentifiers.RegisterTag + +type 'a register_env = 'a Identifiers.identifier_map + diff --git a/extracted/registers.mli b/extracted/registers.mli new file mode 100644 index 0000000..a6a4105 --- /dev/null +++ b/extracted/registers.mli @@ -0,0 +1,62 @@ +open Preamble + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Identifiers + +open Order + +type register = PreIdentifiers.identifier + +val register_eq : register -> register -> (__, __) Types.sum + +type 'a register_env = 'a Identifiers.identifier_map + diff --git a/extracted/relations.ml b/extracted/relations.ml new file mode 100644 index 0000000..875203b --- /dev/null +++ b/extracted/relations.ml @@ -0,0 +1,24 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +type 'x predicate = __ + +type 'x relation = __ + +type ('x0, 'x) relation2 = __ + +type ('x1, 'x0, 'x) relation3 = __ + +(** val compose : ('a2 -> 'a3) -> ('a1 -> 'a2) -> 'a1 -> 'a3 **) +let compose f g x = + f (g x) + +type ('x0, 'x) bi_relation = __ + diff --git a/extracted/relations.mli b/extracted/relations.mli new file mode 100644 index 0000000..a5597de --- /dev/null +++ b/extracted/relations.mli @@ -0,0 +1,22 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +type 'x predicate = __ + +type 'x relation = __ + +type ('x0, 'x) relation2 = __ + +type ('x1, 'x0, 'x) relation3 = __ + +val compose : ('a2 -> 'a3) -> ('a1 -> 'a2) -> 'a1 -> 'a3 + +type ('x0, 'x) bi_relation = __ + diff --git a/extracted/russell.ml b/extracted/russell.ml new file mode 100644 index 0000000..4a870cb --- /dev/null +++ b/extracted/russell.ml @@ -0,0 +1,14 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Types + diff --git a/extracted/russell.mli b/extracted/russell.mli new file mode 100644 index 0000000..4a870cb --- /dev/null +++ b/extracted/russell.mli @@ -0,0 +1,14 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Types + diff --git a/extracted/semantics.ml b/extracted/semantics.ml new file mode 100644 index 0000000..221a22e --- /dev/null +++ b/extracted/semantics.ml @@ -0,0 +1,469 @@ +open Preamble + +open UtilBranch + +open ASMCostsSplit + +open StructuredTraces + +open AbstractStatus + +open StatusProofs + +open Interpret + +open ASMCosts + +open Assembly + +open Status + +open Fetch + +open PolicyFront + +open PolicyStep + +open Policy + +open AssocList + +open Uses + +open ASM + +open BitVectorTrieSet + +open LINToASM + +open LIN + +open Linearise + +open LTLToLIN + +open Fixpoints + +open Set_adt + +open Liveness + +open Interference + +open Joint_LTL_LIN + +open LTL + +open ERTLToLTL + +open ERTL + +open RegisterSet + +open RTLToERTL + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open String + +open LabelledObjects + +open I8051 + +open BackEndOps + +open Joint + +open RTL + +open RTLabsToRTL + +open CostInj + +open Deqsets_extra + +open CostMisc + +open Listb_extra + +open CostSpec + +open CostCheck + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open RTLabs_syntax + +open ToRTLabs + +open FrontEndOps + +open Cminor_syntax + +open ToCminor + +open MemProperties + +open MemoryInjections + +open Fresh + +open SwitchRemoval + +open Sets + +open Listb + +open Star + +open Frontend_misc + +open CexecInd + +open Casts + +open ClassifyOp + +open Smallstep + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open Events + +open IOMonad + +open IO + +open Cexec + +open TypeComparison + +open SimplifyCasts + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open Label + +open Compiler + +open Stacksize + +open Executions + +open Measurable + +open Clight_abstract + +open Clight_classified_system + +open Cminor_semantics + +open Cminor_abstract + +open Cminor_classified_system + +open RTLabs_semantics + +open RTLabs_abstract + +open RTLabs_classified_system + +open ExtraMonads + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Joint_semantics + +open SemanticsUtils + +open Traces + +open Joint_fullexec + +open RTL_semantics + +open ERTL_semantics + +open Joint_LTL_LIN_semantics + +open LTL_semantics + +open LIN_semantics + +open Interpret2 + +type preclassified_system_pass = + Measurable.preclassified_system + (* singleton inductive, whose constructor was mk_preclassified_system_pass *) + +(** val preclassified_system_pass_rect_Type4 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 **) +let rec preclassified_system_pass_rect_Type4 p h_mk_preclassified_system_pass x_25220 = + let pcs_pcs = x_25220 in h_mk_preclassified_system_pass pcs_pcs __ + +(** val preclassified_system_pass_rect_Type5 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 **) +let rec preclassified_system_pass_rect_Type5 p h_mk_preclassified_system_pass x_25222 = + let pcs_pcs = x_25222 in h_mk_preclassified_system_pass pcs_pcs __ + +(** val preclassified_system_pass_rect_Type3 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 **) +let rec preclassified_system_pass_rect_Type3 p h_mk_preclassified_system_pass x_25224 = + let pcs_pcs = x_25224 in h_mk_preclassified_system_pass pcs_pcs __ + +(** val preclassified_system_pass_rect_Type2 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 **) +let rec preclassified_system_pass_rect_Type2 p h_mk_preclassified_system_pass x_25226 = + let pcs_pcs = x_25226 in h_mk_preclassified_system_pass pcs_pcs __ + +(** val preclassified_system_pass_rect_Type1 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 **) +let rec preclassified_system_pass_rect_Type1 p h_mk_preclassified_system_pass x_25228 = + let pcs_pcs = x_25228 in h_mk_preclassified_system_pass pcs_pcs __ + +(** val preclassified_system_pass_rect_Type0 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 **) +let rec preclassified_system_pass_rect_Type0 p h_mk_preclassified_system_pass x_25230 = + let pcs_pcs = x_25230 in h_mk_preclassified_system_pass pcs_pcs __ + +(** val pcs_pcs : + Compiler.pass -> preclassified_system_pass -> + Measurable.preclassified_system **) +let rec pcs_pcs p xxx = + let yyy = xxx in yyy + +(** val preclassified_system_pass_inv_rect_Type4 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 **) +let preclassified_system_pass_inv_rect_Type4 x1 hterm h1 = + let hcut = preclassified_system_pass_rect_Type4 x1 h1 hterm in hcut __ + +(** val preclassified_system_pass_inv_rect_Type3 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 **) +let preclassified_system_pass_inv_rect_Type3 x1 hterm h1 = + let hcut = preclassified_system_pass_rect_Type3 x1 h1 hterm in hcut __ + +(** val preclassified_system_pass_inv_rect_Type2 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 **) +let preclassified_system_pass_inv_rect_Type2 x1 hterm h1 = + let hcut = preclassified_system_pass_rect_Type2 x1 h1 hterm in hcut __ + +(** val preclassified_system_pass_inv_rect_Type1 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 **) +let preclassified_system_pass_inv_rect_Type1 x1 hterm h1 = + let hcut = preclassified_system_pass_rect_Type1 x1 h1 hterm in hcut __ + +(** val preclassified_system_pass_inv_rect_Type0 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 **) +let preclassified_system_pass_inv_rect_Type0 x1 hterm h1 = + let hcut = preclassified_system_pass_rect_Type0 x1 h1 hterm in hcut __ + +(** val pcs_pcs__o__pcs_exec : + Compiler.pass -> preclassified_system_pass -> (IO.io_out, IO.io_in) + SmallstepExec.fullexec **) +let pcs_pcs__o__pcs_exec x0 x1 = + (pcs_pcs x0 x1).Measurable.pcs_exec + +(** val pcs_pcs__o__pcs_exec__o__es1 : + Compiler.pass -> preclassified_system_pass -> (IO.io_out, IO.io_in) + SmallstepExec.trans_system **) +let pcs_pcs__o__pcs_exec__o__es1 x0 x1 = + Measurable.pcs_exec__o__es1 (pcs_pcs x0 x1) + +(** val preclassified_system_of_pass : + Compiler.pass -> Compiler.syntax_of_pass -> preclassified_system_pass **) +let preclassified_system_of_pass = function +| Compiler.Clight_pass -> (fun x -> Clight_classified_system.clight_pcs) +| Compiler.Clight_switch_removed_pass -> + (fun x -> Clight_classified_system.clight_pcs) +| Compiler.Clight_label_pass -> + (fun x -> Clight_classified_system.clight_pcs) +| Compiler.Clight_simplified_pass -> + (fun x -> Clight_classified_system.clight_pcs) +| Compiler.Cminor_pass -> (fun x -> Cminor_classified_system.cminor_pcs) +| Compiler.Rtlabs_pass -> (fun x -> RTLabs_classified_system.rTLabs_pcs) +| Compiler.Rtl_separate_pass -> + (fun x -> + Joint_fullexec.joint_preclassified_system + (SemanticsUtils.sem_graph_params_to_sem_params + RTL_semantics.rTL_semantics_separate)) +| Compiler.Rtl_uniq_pass -> + (fun x -> + Joint_fullexec.joint_preclassified_system + (SemanticsUtils.sem_graph_params_to_sem_params + RTL_semantics.rTL_semantics_unique)) +| Compiler.Ertl_pass -> + (fun x -> + Joint_fullexec.joint_preclassified_system + (SemanticsUtils.sem_graph_params_to_sem_params + ERTL_semantics.eRTL_semantics)) +| Compiler.Ltl_pass -> + (fun x -> + Joint_fullexec.joint_preclassified_system + (SemanticsUtils.sem_graph_params_to_sem_params + LTL_semantics.lTL_semantics)) +| Compiler.Lin_pass -> + (fun x -> + Joint_fullexec.joint_preclassified_system LIN_semantics.lIN_semantics) +| Compiler.Assembly_pass -> + (fun prog -> + let { Types.fst = eta32049; Types.snd = policy } = Obj.magic prog in + let { Types.fst = code; Types.snd = sigma } = eta32049 in + Interpret2.aSM_preclassified_system code sigma policy) +| Compiler.Object_code_pass -> + (fun prog -> Interpret2.oC_preclassified_system (Obj.magic prog)) + +(** val run_and_print : + Compiler.pass -> Compiler.syntax_of_pass -> Nat.nat -> (Compiler.pass -> + Types.unit0) -> (StructuredTraces.intensional_event -> Types.unit0) -> + (Errors.errmsg -> Types.unit0) -> (Integers.int -> Types.unit0) -> + Types.unit0 **) +let run_and_print pass prog n print_pass print_event print_error print_exit = + let res = + let pcs = preclassified_system_of_pass pass prog in + let prog0 = prog in + let g = (pcs_pcs__o__pcs_exec pass pcs).SmallstepExec.make_global prog0 + in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + ((pcs_pcs__o__pcs_exec pass pcs).SmallstepExec.make_initial_state + prog0)) (fun s0 -> + let i = print_pass pass in + let { Types.fst = trace; Types.snd = res } = + Measurable.observe_all_in_measurable n + (Measurable.pcs_to_cs (pcs_pcs pass pcs) + ((pcs_pcs__o__pcs_exec pass pcs).SmallstepExec.make_global prog0)) + print_event List.Nil s0 + in + Obj.magic res) + in + (match Obj.magic res with + | Errors.OK n0 -> print_exit n0 + | Errors.Error msg -> print_error msg) + diff --git a/extracted/semantics.mli b/extracted/semantics.mli new file mode 100644 index 0000000..68973c5 --- /dev/null +++ b/extracted/semantics.mli @@ -0,0 +1,379 @@ +open Preamble + +open UtilBranch + +open ASMCostsSplit + +open StructuredTraces + +open AbstractStatus + +open StatusProofs + +open Interpret + +open ASMCosts + +open Assembly + +open Status + +open Fetch + +open PolicyFront + +open PolicyStep + +open Policy + +open AssocList + +open Uses + +open ASM + +open BitVectorTrieSet + +open LINToASM + +open LIN + +open Linearise + +open LTLToLIN + +open Fixpoints + +open Set_adt + +open Liveness + +open Interference + +open Joint_LTL_LIN + +open LTL + +open ERTLToLTL + +open ERTL + +open RegisterSet + +open RTLToERTL + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open String + +open LabelledObjects + +open I8051 + +open BackEndOps + +open Joint + +open RTL + +open RTLabsToRTL + +open CostInj + +open Deqsets_extra + +open CostMisc + +open Listb_extra + +open CostSpec + +open CostCheck + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open RTLabs_syntax + +open ToRTLabs + +open FrontEndOps + +open Cminor_syntax + +open ToCminor + +open MemProperties + +open MemoryInjections + +open Fresh + +open SwitchRemoval + +open Sets + +open Listb + +open Star + +open Frontend_misc + +open CexecInd + +open Casts + +open ClassifyOp + +open Smallstep + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open Events + +open IOMonad + +open IO + +open Cexec + +open TypeComparison + +open SimplifyCasts + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open Label + +open Compiler + +open Stacksize + +open Executions + +open Measurable + +open Clight_abstract + +open Clight_classified_system + +open Cminor_semantics + +open Cminor_abstract + +open Cminor_classified_system + +open RTLabs_semantics + +open RTLabs_abstract + +open RTLabs_classified_system + +open ExtraMonads + +open ExtraGlobalenvs + +open I8051bis + +open BEMem + +open Joint_semantics + +open SemanticsUtils + +open Traces + +open Joint_fullexec + +open RTL_semantics + +open ERTL_semantics + +open Joint_LTL_LIN_semantics + +open LTL_semantics + +open LIN_semantics + +open Interpret2 + +type preclassified_system_pass = + Measurable.preclassified_system + (* singleton inductive, whose constructor was mk_preclassified_system_pass *) + +val preclassified_system_pass_rect_Type4 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 + +val preclassified_system_pass_rect_Type5 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 + +val preclassified_system_pass_rect_Type3 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 + +val preclassified_system_pass_rect_Type2 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 + +val preclassified_system_pass_rect_Type1 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 + +val preclassified_system_pass_rect_Type0 : + Compiler.pass -> (Measurable.preclassified_system -> __ -> 'a1) -> + preclassified_system_pass -> 'a1 + +val pcs_pcs : + Compiler.pass -> preclassified_system_pass -> + Measurable.preclassified_system + +val preclassified_system_pass_inv_rect_Type4 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 + +val preclassified_system_pass_inv_rect_Type3 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 + +val preclassified_system_pass_inv_rect_Type2 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 + +val preclassified_system_pass_inv_rect_Type1 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 + +val preclassified_system_pass_inv_rect_Type0 : + Compiler.pass -> preclassified_system_pass -> + (Measurable.preclassified_system -> __ -> __ -> 'a1) -> 'a1 + +val pcs_pcs__o__pcs_exec : + Compiler.pass -> preclassified_system_pass -> (IO.io_out, IO.io_in) + SmallstepExec.fullexec + +val pcs_pcs__o__pcs_exec__o__es1 : + Compiler.pass -> preclassified_system_pass -> (IO.io_out, IO.io_in) + SmallstepExec.trans_system + +val preclassified_system_of_pass : + Compiler.pass -> Compiler.syntax_of_pass -> preclassified_system_pass + +val run_and_print : + Compiler.pass -> Compiler.syntax_of_pass -> Nat.nat -> (Compiler.pass -> + Types.unit0) -> (StructuredTraces.intensional_event -> Types.unit0) -> + (Errors.errmsg -> Types.unit0) -> (Integers.int -> Types.unit0) -> + Types.unit0 + diff --git a/extracted/semanticsUtils.ml b/extracted/semanticsUtils.ml new file mode 100644 index 0000000..26edcd4 --- /dev/null +++ b/extracted/semanticsUtils.ml @@ -0,0 +1,767 @@ +open Preamble + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraMonads + +(** val reg_store : + PreIdentifiers.identifier -> ByteValues.beval -> ByteValues.beval + Identifiers.identifier_map -> ByteValues.beval Identifiers.identifier_map **) +let reg_store reg v locals = + Identifiers.add PreIdentifiers.RegisterTag locals reg v + +(** val reg_retrieve : + ByteValues.beval Registers.register_env -> Registers.register -> + ByteValues.beval Errors.res **) +let reg_retrieve locals reg = + Errors.opt_to_res (List.Cons ((Errors.MSG ErrorMessages.BadRegister), + (List.Cons ((Errors.CTX (PreIdentifiers.RegisterTag, reg)), List.Nil)))) + (Identifiers.lookup PreIdentifiers.RegisterTag locals reg) + +type hw_register_env = { reg_env : ByteValues.beval + BitVectorTrie.bitVectorTrie; + other_bit : ByteValues.bebit } + +(** val hw_register_env_rect_Type4 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 **) +let rec hw_register_env_rect_Type4 h_mk_hw_register_env x_25009 = + let { reg_env = reg_env0; other_bit = other_bit0 } = x_25009 in + h_mk_hw_register_env reg_env0 other_bit0 + +(** val hw_register_env_rect_Type5 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 **) +let rec hw_register_env_rect_Type5 h_mk_hw_register_env x_25011 = + let { reg_env = reg_env0; other_bit = other_bit0 } = x_25011 in + h_mk_hw_register_env reg_env0 other_bit0 + +(** val hw_register_env_rect_Type3 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 **) +let rec hw_register_env_rect_Type3 h_mk_hw_register_env x_25013 = + let { reg_env = reg_env0; other_bit = other_bit0 } = x_25013 in + h_mk_hw_register_env reg_env0 other_bit0 + +(** val hw_register_env_rect_Type2 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 **) +let rec hw_register_env_rect_Type2 h_mk_hw_register_env x_25015 = + let { reg_env = reg_env0; other_bit = other_bit0 } = x_25015 in + h_mk_hw_register_env reg_env0 other_bit0 + +(** val hw_register_env_rect_Type1 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 **) +let rec hw_register_env_rect_Type1 h_mk_hw_register_env x_25017 = + let { reg_env = reg_env0; other_bit = other_bit0 } = x_25017 in + h_mk_hw_register_env reg_env0 other_bit0 + +(** val hw_register_env_rect_Type0 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 **) +let rec hw_register_env_rect_Type0 h_mk_hw_register_env x_25019 = + let { reg_env = reg_env0; other_bit = other_bit0 } = x_25019 in + h_mk_hw_register_env reg_env0 other_bit0 + +(** val reg_env : + hw_register_env -> ByteValues.beval BitVectorTrie.bitVectorTrie **) +let rec reg_env xxx = + xxx.reg_env + +(** val other_bit : hw_register_env -> ByteValues.bebit **) +let rec other_bit xxx = + xxx.other_bit + +(** val hw_register_env_inv_rect_Type4 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 **) +let hw_register_env_inv_rect_Type4 hterm h1 = + let hcut = hw_register_env_rect_Type4 h1 hterm in hcut __ + +(** val hw_register_env_inv_rect_Type3 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 **) +let hw_register_env_inv_rect_Type3 hterm h1 = + let hcut = hw_register_env_rect_Type3 h1 hterm in hcut __ + +(** val hw_register_env_inv_rect_Type2 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 **) +let hw_register_env_inv_rect_Type2 hterm h1 = + let hcut = hw_register_env_rect_Type2 h1 hterm in hcut __ + +(** val hw_register_env_inv_rect_Type1 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 **) +let hw_register_env_inv_rect_Type1 hterm h1 = + let hcut = hw_register_env_rect_Type1 h1 hterm in hcut __ + +(** val hw_register_env_inv_rect_Type0 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 **) +let hw_register_env_inv_rect_Type0 hterm h1 = + let hcut = hw_register_env_rect_Type0 h1 hterm in hcut __ + +(** val hw_register_env_discr : hw_register_env -> hw_register_env -> __ **) +let hw_register_env_discr x y = + Logic.eq_rect_Type2 x + (let { reg_env = a0; other_bit = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val hw_register_env_jmdiscr : + hw_register_env -> hw_register_env -> __ **) +let hw_register_env_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { reg_env = a0; other_bit = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val hwreg_retrieve : + hw_register_env -> I8051.register -> ByteValues.beval **) +let hwreg_retrieve env r = + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) + (I8051.bitvector_of_register r) env.reg_env ByteValues.BVundef + +(** val hwreg_store : + I8051.register -> ByteValues.beval -> hw_register_env -> hw_register_env **) +let hwreg_store r v env = + { reg_env = + (BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (I8051.bitvector_of_register r) v env.reg_env); other_bit = + env.other_bit } + +(** val hwreg_set_other : + ByteValues.bebit -> hw_register_env -> hw_register_env **) +let hwreg_set_other v env = + { reg_env = env.reg_env; other_bit = v } + +(** val hwreg_retrieve_sp : + hw_register_env -> ByteValues.xpointer Errors.res **) +let hwreg_retrieve_sp env = + let spl = hwreg_retrieve env I8051.registerSPL in + let sph = hwreg_retrieve env I8051.registerSPH in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (BEMem.pointer_of_address { Types.fst = spl; Types.snd = sph })) + (fun ptr -> + (match Pointers.ptype ptr with + | AST.XData -> + (fun _ -> Monad.m_return0 (Monad.max_def Errors.res0) ptr) + | AST.Code -> + (fun _ -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BadPointer), List.Nil))))) __)) + +(** val hwreg_store_sp : + hw_register_env -> ByteValues.xpointer -> hw_register_env **) +let hwreg_store_sp env sp = + let { Types.fst = spl; Types.snd = sph } = + ByteValues.beval_pair_of_pointer (Types.pi1 sp) + in + hwreg_store I8051.registerSPH sph (hwreg_store I8051.registerSPL spl env) + +(** val init_hw_register_env : ByteValues.xpointer -> hw_register_env **) +let init_hw_register_env = + hwreg_store_sp { reg_env = (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))); other_bit = ByteValues.BBundef } + +type sem_graph_params = { sgp_pars : Joint.uns_params; + sgp_sup : (__ -> __ + Joint_semantics.sem_unserialized_params); + graph_pre_main_generator : (Joint.joint_program -> + Joint.joint_closed_internal_function) } + +(** val sem_graph_params_rect_Type4 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_graph_params -> 'a1 **) +let rec sem_graph_params_rect_Type4 h_mk_sem_graph_params x_25035 = + let { sgp_pars = sgp_pars0; sgp_sup = sgp_sup0; graph_pre_main_generator = + graph_pre_main_generator0 } = x_25035 + in + h_mk_sem_graph_params sgp_pars0 sgp_sup0 graph_pre_main_generator0 + +(** val sem_graph_params_rect_Type5 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_graph_params -> 'a1 **) +let rec sem_graph_params_rect_Type5 h_mk_sem_graph_params x_25037 = + let { sgp_pars = sgp_pars0; sgp_sup = sgp_sup0; graph_pre_main_generator = + graph_pre_main_generator0 } = x_25037 + in + h_mk_sem_graph_params sgp_pars0 sgp_sup0 graph_pre_main_generator0 + +(** val sem_graph_params_rect_Type3 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_graph_params -> 'a1 **) +let rec sem_graph_params_rect_Type3 h_mk_sem_graph_params x_25039 = + let { sgp_pars = sgp_pars0; sgp_sup = sgp_sup0; graph_pre_main_generator = + graph_pre_main_generator0 } = x_25039 + in + h_mk_sem_graph_params sgp_pars0 sgp_sup0 graph_pre_main_generator0 + +(** val sem_graph_params_rect_Type2 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_graph_params -> 'a1 **) +let rec sem_graph_params_rect_Type2 h_mk_sem_graph_params x_25041 = + let { sgp_pars = sgp_pars0; sgp_sup = sgp_sup0; graph_pre_main_generator = + graph_pre_main_generator0 } = x_25041 + in + h_mk_sem_graph_params sgp_pars0 sgp_sup0 graph_pre_main_generator0 + +(** val sem_graph_params_rect_Type1 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_graph_params -> 'a1 **) +let rec sem_graph_params_rect_Type1 h_mk_sem_graph_params x_25043 = + let { sgp_pars = sgp_pars0; sgp_sup = sgp_sup0; graph_pre_main_generator = + graph_pre_main_generator0 } = x_25043 + in + h_mk_sem_graph_params sgp_pars0 sgp_sup0 graph_pre_main_generator0 + +(** val sem_graph_params_rect_Type0 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_graph_params -> 'a1 **) +let rec sem_graph_params_rect_Type0 h_mk_sem_graph_params x_25045 = + let { sgp_pars = sgp_pars0; sgp_sup = sgp_sup0; graph_pre_main_generator = + graph_pre_main_generator0 } = x_25045 + in + h_mk_sem_graph_params sgp_pars0 sgp_sup0 graph_pre_main_generator0 + +(** val sgp_pars : sem_graph_params -> Joint.uns_params **) +let rec sgp_pars xxx = + xxx.sgp_pars + +(** val sgp_sup0 : + sem_graph_params -> 'a1 Joint_semantics.sem_unserialized_params **) +let rec sgp_sup0 xxx = + (let { sgp_pars = x; sgp_sup = yyy; graph_pre_main_generator = x0 } = xxx + in + Obj.magic yyy) __ + +(** val graph_pre_main_generator : + sem_graph_params -> Joint.joint_program -> + Joint.joint_closed_internal_function **) +let rec graph_pre_main_generator xxx = + xxx.graph_pre_main_generator + +(** val sem_graph_params_inv_rect_Type4 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_graph_params_inv_rect_Type4 hterm h1 = + let hcut = sem_graph_params_rect_Type4 h1 hterm in hcut __ + +(** val sem_graph_params_inv_rect_Type3 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_graph_params_inv_rect_Type3 hterm h1 = + let hcut = sem_graph_params_rect_Type3 h1 hterm in hcut __ + +(** val sem_graph_params_inv_rect_Type2 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_graph_params_inv_rect_Type2 hterm h1 = + let hcut = sem_graph_params_rect_Type2 h1 hterm in hcut __ + +(** val sem_graph_params_inv_rect_Type1 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_graph_params_inv_rect_Type1 hterm h1 = + let hcut = sem_graph_params_rect_Type1 h1 hterm in hcut __ + +(** val sem_graph_params_inv_rect_Type0 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_graph_params_inv_rect_Type0 hterm h1 = + let hcut = sem_graph_params_rect_Type0 h1 hterm in hcut __ + +(** val sem_graph_params_jmdiscr : + sem_graph_params -> sem_graph_params -> __ **) +let sem_graph_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { sgp_pars = a0; sgp_sup = a1; graph_pre_main_generator = a2 } = x + in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val sem_graph_params_to_graph_params : + sem_graph_params -> Joint.graph_params **) +let sem_graph_params_to_graph_params pars = + pars.sgp_pars + +(** val sem_graph_params_to_sem_params : + sem_graph_params -> Joint_semantics.sem_params **) +let sem_graph_params_to_sem_params pars = + { Joint_semantics.spp' = { Joint_semantics.spp = + (let x = sem_graph_params_to_graph_params pars in + Joint.graph_params_to_params x); Joint_semantics.msu_pars = + (sgp_sup0 pars); Joint_semantics.offset_of_point = + (Obj.magic (Identifiers.word_of_identifier PreIdentifiers.LabelTag)); + Joint_semantics.point_of_offset = (Obj.magic (fun x -> x)) }; + Joint_semantics.pre_main_generator = pars.graph_pre_main_generator } + +(** val sem_params_from_sem_graph_params__o__spp' : + sem_graph_params -> Joint_semantics.serialized_params **) +let sem_params_from_sem_graph_params__o__spp' x0 = + (sem_graph_params_to_sem_params x0).Joint_semantics.spp' + +(** val sem_params_from_sem_graph_params__o__spp'__o__msu_pars : + sem_graph_params -> Joint.joint_closed_internal_function + Joint_semantics.sem_unserialized_params **) +let sem_params_from_sem_graph_params__o__spp'__o__msu_pars x0 = + Joint_semantics.spp'__o__msu_pars (sem_graph_params_to_sem_params x0) + +(** val sem_params_from_sem_graph_params__o__spp'__o__msu_pars__o__st_pars : + sem_graph_params -> Joint_semantics.sem_state_params **) +let sem_params_from_sem_graph_params__o__spp'__o__msu_pars__o__st_pars x0 = + Joint_semantics.spp'__o__msu_pars__o__st_pars + (sem_graph_params_to_sem_params x0) + +(** val sem_params_from_sem_graph_params__o__spp'__o__spp : + sem_graph_params -> Joint.params **) +let sem_params_from_sem_graph_params__o__spp'__o__spp x0 = + Joint_semantics.spp'__o__spp (sem_graph_params_to_sem_params x0) + +(** val sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars : + sem_graph_params -> Joint.stmt_params **) +let sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars + (sem_graph_params_to_sem_params x0) + +(** val sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars : + sem_graph_params -> Joint.uns_params **) +let sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars__o__uns_pars + (sem_graph_params_to_sem_params x0) + +(** val sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + sem_graph_params -> Joint.unserialized_params **) +let sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars + (sem_graph_params_to_sem_params x0) + +type sem_lin_params = { slp_pars : Joint.uns_params; + slp_sup : (__ -> __ + Joint_semantics.sem_unserialized_params); + lin_pre_main_generator : (Joint.joint_program -> + Joint.joint_closed_internal_function) } + +(** val sem_lin_params_rect_Type4 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_lin_params -> 'a1 **) +let rec sem_lin_params_rect_Type4 h_mk_sem_lin_params x_25062 = + let { slp_pars = slp_pars0; slp_sup = slp_sup0; lin_pre_main_generator = + lin_pre_main_generator0 } = x_25062 + in + h_mk_sem_lin_params slp_pars0 slp_sup0 lin_pre_main_generator0 + +(** val sem_lin_params_rect_Type5 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_lin_params -> 'a1 **) +let rec sem_lin_params_rect_Type5 h_mk_sem_lin_params x_25064 = + let { slp_pars = slp_pars0; slp_sup = slp_sup0; lin_pre_main_generator = + lin_pre_main_generator0 } = x_25064 + in + h_mk_sem_lin_params slp_pars0 slp_sup0 lin_pre_main_generator0 + +(** val sem_lin_params_rect_Type3 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_lin_params -> 'a1 **) +let rec sem_lin_params_rect_Type3 h_mk_sem_lin_params x_25066 = + let { slp_pars = slp_pars0; slp_sup = slp_sup0; lin_pre_main_generator = + lin_pre_main_generator0 } = x_25066 + in + h_mk_sem_lin_params slp_pars0 slp_sup0 lin_pre_main_generator0 + +(** val sem_lin_params_rect_Type2 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_lin_params -> 'a1 **) +let rec sem_lin_params_rect_Type2 h_mk_sem_lin_params x_25068 = + let { slp_pars = slp_pars0; slp_sup = slp_sup0; lin_pre_main_generator = + lin_pre_main_generator0 } = x_25068 + in + h_mk_sem_lin_params slp_pars0 slp_sup0 lin_pre_main_generator0 + +(** val sem_lin_params_rect_Type1 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_lin_params -> 'a1 **) +let rec sem_lin_params_rect_Type1 h_mk_sem_lin_params x_25070 = + let { slp_pars = slp_pars0; slp_sup = slp_sup0; lin_pre_main_generator = + lin_pre_main_generator0 } = x_25070 + in + h_mk_sem_lin_params slp_pars0 slp_sup0 lin_pre_main_generator0 + +(** val sem_lin_params_rect_Type0 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) + -> (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) + -> sem_lin_params -> 'a1 **) +let rec sem_lin_params_rect_Type0 h_mk_sem_lin_params x_25072 = + let { slp_pars = slp_pars0; slp_sup = slp_sup0; lin_pre_main_generator = + lin_pre_main_generator0 } = x_25072 + in + h_mk_sem_lin_params slp_pars0 slp_sup0 lin_pre_main_generator0 + +(** val slp_pars : sem_lin_params -> Joint.uns_params **) +let rec slp_pars xxx = + xxx.slp_pars + +(** val slp_sup0 : + sem_lin_params -> 'a1 Joint_semantics.sem_unserialized_params **) +let rec slp_sup0 xxx = + (let { slp_pars = x; slp_sup = yyy; lin_pre_main_generator = x0 } = xxx in + Obj.magic yyy) __ + +(** val lin_pre_main_generator : + sem_lin_params -> Joint.joint_program -> + Joint.joint_closed_internal_function **) +let rec lin_pre_main_generator xxx = + xxx.lin_pre_main_generator + +(** val sem_lin_params_inv_rect_Type4 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_lin_params_inv_rect_Type4 hterm h1 = + let hcut = sem_lin_params_rect_Type4 h1 hterm in hcut __ + +(** val sem_lin_params_inv_rect_Type3 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_lin_params_inv_rect_Type3 hterm h1 = + let hcut = sem_lin_params_rect_Type3 h1 hterm in hcut __ + +(** val sem_lin_params_inv_rect_Type2 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_lin_params_inv_rect_Type2 hterm h1 = + let hcut = sem_lin_params_rect_Type2 h1 hterm in hcut __ + +(** val sem_lin_params_inv_rect_Type1 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_lin_params_inv_rect_Type1 hterm h1 = + let hcut = sem_lin_params_rect_Type1 h1 hterm in hcut __ + +(** val sem_lin_params_inv_rect_Type0 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 **) +let sem_lin_params_inv_rect_Type0 hterm h1 = + let hcut = sem_lin_params_rect_Type0 h1 hterm in hcut __ + +(** val sem_lin_params_jmdiscr : sem_lin_params -> sem_lin_params -> __ **) +let sem_lin_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { slp_pars = a0; slp_sup = a1; lin_pre_main_generator = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val sem_lin_params_to_lin_params : sem_lin_params -> Joint.lin_params **) +let sem_lin_params_to_lin_params pars = + pars.slp_pars + +(** val sem_lin_params_to_sem_params : + sem_lin_params -> Joint_semantics.sem_params **) +let sem_lin_params_to_sem_params pars = + { Joint_semantics.spp' = { Joint_semantics.spp = + (let x = sem_lin_params_to_lin_params pars in + Joint.lin_params_to_params x); Joint_semantics.msu_pars = + (slp_sup0 pars); Joint_semantics.offset_of_point = + (Obj.magic Positive.succ_pos_of_nat); Joint_semantics.point_of_offset = + (fun p -> Obj.magic (Nat.pred (Positive.nat_of_pos p))) }; + Joint_semantics.pre_main_generator = pars.lin_pre_main_generator } + +(** val sem_params_from_sem_lin_params__o__spp' : + sem_lin_params -> Joint_semantics.serialized_params **) +let sem_params_from_sem_lin_params__o__spp' x0 = + (sem_lin_params_to_sem_params x0).Joint_semantics.spp' + +(** val sem_params_from_sem_lin_params__o__spp'__o__msu_pars : + sem_lin_params -> Joint.joint_closed_internal_function + Joint_semantics.sem_unserialized_params **) +let sem_params_from_sem_lin_params__o__spp'__o__msu_pars x0 = + Joint_semantics.spp'__o__msu_pars (sem_lin_params_to_sem_params x0) + +(** val sem_params_from_sem_lin_params__o__spp'__o__msu_pars__o__st_pars : + sem_lin_params -> Joint_semantics.sem_state_params **) +let sem_params_from_sem_lin_params__o__spp'__o__msu_pars__o__st_pars x0 = + Joint_semantics.spp'__o__msu_pars__o__st_pars + (sem_lin_params_to_sem_params x0) + +(** val sem_params_from_sem_lin_params__o__spp'__o__spp : + sem_lin_params -> Joint.params **) +let sem_params_from_sem_lin_params__o__spp'__o__spp x0 = + Joint_semantics.spp'__o__spp (sem_lin_params_to_sem_params x0) + +(** val sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars : + sem_lin_params -> Joint.stmt_params **) +let sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars + (sem_lin_params_to_sem_params x0) + +(** val sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars : + sem_lin_params -> Joint.uns_params **) +let sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars__o__uns_pars + (sem_lin_params_to_sem_params x0) + +(** val sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + sem_lin_params -> Joint.unserialized_params **) +let sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars + (sem_lin_params_to_sem_params x0) + +(** val match_genv_t_rect_Type4 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec match_genv_t_rect_Type4 m vars ge1 ge2 h_mk_match_genv_t = + h_mk_match_genv_t __ __ __ + +(** val match_genv_t_rect_Type5 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec match_genv_t_rect_Type5 m vars ge1 ge2 h_mk_match_genv_t = + h_mk_match_genv_t __ __ __ + +(** val match_genv_t_rect_Type3 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec match_genv_t_rect_Type3 m vars ge1 ge2 h_mk_match_genv_t = + h_mk_match_genv_t __ __ __ + +(** val match_genv_t_rect_Type2 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec match_genv_t_rect_Type2 m vars ge1 ge2 h_mk_match_genv_t = + h_mk_match_genv_t __ __ __ + +(** val match_genv_t_rect_Type1 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec match_genv_t_rect_Type1 m vars ge1 ge2 h_mk_match_genv_t = + h_mk_match_genv_t __ __ __ + +(** val match_genv_t_rect_Type0 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec match_genv_t_rect_Type0 m vars ge1 ge2 h_mk_match_genv_t = + h_mk_match_genv_t __ __ __ + +(** val match_genv_t_inv_rect_Type4 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let match_genv_t_inv_rect_Type4 x1 x2 x3 x4 h1 = + let hcut = match_genv_t_rect_Type4 x1 x2 x3 x4 h1 in hcut __ + +(** val match_genv_t_inv_rect_Type3 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let match_genv_t_inv_rect_Type3 x1 x2 x3 x4 h1 = + let hcut = match_genv_t_rect_Type3 x1 x2 x3 x4 h1 in hcut __ + +(** val match_genv_t_inv_rect_Type2 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let match_genv_t_inv_rect_Type2 x1 x2 x3 x4 h1 = + let hcut = match_genv_t_rect_Type2 x1 x2 x3 x4 h1 in hcut __ + +(** val match_genv_t_inv_rect_Type1 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let match_genv_t_inv_rect_Type1 x1 x2 x3 x4 h1 = + let hcut = match_genv_t_rect_Type1 x1 x2 x3 x4 h1 in hcut __ + +(** val match_genv_t_inv_rect_Type0 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let match_genv_t_inv_rect_Type0 x1 x2 x3 x4 h1 = + let hcut = match_genv_t_rect_Type0 x1 x2 x3 x4 h1 in hcut __ + +(** val match_genv_t_discr : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> __ **) +let match_genv_t_discr a1 a2 a3 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val match_genv_t_jmdiscr : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> __ **) +let match_genv_t_jmdiscr a1 a2 a3 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val joint_globalenv : + Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> Joint_semantics.genv **) +let joint_globalenv p prog stacksizes = + let genv = Globalenvs.globalenv (fun x -> x) prog.Joint.joint_prog in + let pc_from_lbl = fun bl fn lbl -> + Monad.m_bind0 (Monad.max_def Option.option) + (Obj.magic + ((Joint_semantics.spp'__o__spp p).Joint.point_of_label + (Joint.prog_names (Joint_semantics.spp'__o__spp p) prog) + (Types.pi1 fn).Joint.joint_if_code lbl)) (fun pt -> + Monad.m_return0 (Monad.max_def Option.option) { ByteValues.pc_block = + bl; ByteValues.pc_offset = + (p.Joint_semantics.spp'.Joint_semantics.offset_of_point pt) }) + in + { Joint_semantics.ge = genv; Joint_semantics.stack_sizes = stacksizes; + Joint_semantics.premain = (p.Joint_semantics.pre_main_generator prog); + Joint_semantics.pc_from_label = (Obj.magic pc_from_lbl) } + diff --git a/extracted/semanticsUtils.mli b/extracted/semanticsUtils.mli new file mode 100644 index 0000000..245a3d2 --- /dev/null +++ b/extracted/semanticsUtils.mli @@ -0,0 +1,479 @@ +open Preamble + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraMonads + +val reg_store : + PreIdentifiers.identifier -> ByteValues.beval -> ByteValues.beval + Identifiers.identifier_map -> ByteValues.beval Identifiers.identifier_map + +val reg_retrieve : + ByteValues.beval Registers.register_env -> Registers.register -> + ByteValues.beval Errors.res + +type hw_register_env = { reg_env : ByteValues.beval + BitVectorTrie.bitVectorTrie; + other_bit : ByteValues.bebit } + +val hw_register_env_rect_Type4 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 + +val hw_register_env_rect_Type5 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 + +val hw_register_env_rect_Type3 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 + +val hw_register_env_rect_Type2 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 + +val hw_register_env_rect_Type1 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 + +val hw_register_env_rect_Type0 : + (ByteValues.beval BitVectorTrie.bitVectorTrie -> ByteValues.bebit -> 'a1) + -> hw_register_env -> 'a1 + +val reg_env : hw_register_env -> ByteValues.beval BitVectorTrie.bitVectorTrie + +val other_bit : hw_register_env -> ByteValues.bebit + +val hw_register_env_inv_rect_Type4 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 + +val hw_register_env_inv_rect_Type3 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 + +val hw_register_env_inv_rect_Type2 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 + +val hw_register_env_inv_rect_Type1 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 + +val hw_register_env_inv_rect_Type0 : + hw_register_env -> (ByteValues.beval BitVectorTrie.bitVectorTrie -> + ByteValues.bebit -> __ -> 'a1) -> 'a1 + +val hw_register_env_discr : hw_register_env -> hw_register_env -> __ + +val hw_register_env_jmdiscr : hw_register_env -> hw_register_env -> __ + +val hwreg_retrieve : hw_register_env -> I8051.register -> ByteValues.beval + +val hwreg_store : + I8051.register -> ByteValues.beval -> hw_register_env -> hw_register_env + +val hwreg_set_other : ByteValues.bebit -> hw_register_env -> hw_register_env + +val hwreg_retrieve_sp : hw_register_env -> ByteValues.xpointer Errors.res + +val hwreg_store_sp : + hw_register_env -> ByteValues.xpointer -> hw_register_env + +val init_hw_register_env : ByteValues.xpointer -> hw_register_env + +type sem_graph_params = { sgp_pars : Joint.uns_params; + sgp_sup : (__ -> __ + Joint_semantics.sem_unserialized_params); + graph_pre_main_generator : (Joint.joint_program -> + Joint.joint_closed_internal_function) } + +val sem_graph_params_rect_Type4 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_graph_params -> 'a1 + +val sem_graph_params_rect_Type5 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_graph_params -> 'a1 + +val sem_graph_params_rect_Type3 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_graph_params -> 'a1 + +val sem_graph_params_rect_Type2 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_graph_params -> 'a1 + +val sem_graph_params_rect_Type1 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_graph_params -> 'a1 + +val sem_graph_params_rect_Type0 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_graph_params -> 'a1 + +val sgp_pars : sem_graph_params -> Joint.uns_params + +val sgp_sup0 : + sem_graph_params -> 'a1 Joint_semantics.sem_unserialized_params + +val graph_pre_main_generator : + sem_graph_params -> Joint.joint_program -> + Joint.joint_closed_internal_function + +val sem_graph_params_inv_rect_Type4 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_graph_params_inv_rect_Type3 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_graph_params_inv_rect_Type2 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_graph_params_inv_rect_Type1 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_graph_params_inv_rect_Type0 : + sem_graph_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_graph_params_jmdiscr : sem_graph_params -> sem_graph_params -> __ + +val sem_graph_params_to_graph_params : sem_graph_params -> Joint.graph_params + +val sem_graph_params_to_sem_params : + sem_graph_params -> Joint_semantics.sem_params + +val sem_params_from_sem_graph_params__o__spp' : + sem_graph_params -> Joint_semantics.serialized_params + +val sem_params_from_sem_graph_params__o__spp'__o__msu_pars : + sem_graph_params -> Joint.joint_closed_internal_function + Joint_semantics.sem_unserialized_params + +val sem_params_from_sem_graph_params__o__spp'__o__msu_pars__o__st_pars : + sem_graph_params -> Joint_semantics.sem_state_params + +val sem_params_from_sem_graph_params__o__spp'__o__spp : + sem_graph_params -> Joint.params + +val sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars : + sem_graph_params -> Joint.stmt_params + +val sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars : + sem_graph_params -> Joint.uns_params + +val sem_params_from_sem_graph_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + sem_graph_params -> Joint.unserialized_params + +type sem_lin_params = { slp_pars : Joint.uns_params; + slp_sup : (__ -> __ + Joint_semantics.sem_unserialized_params); + lin_pre_main_generator : (Joint.joint_program -> + Joint.joint_closed_internal_function) } + +val sem_lin_params_rect_Type4 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_lin_params -> 'a1 + +val sem_lin_params_rect_Type5 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_lin_params -> 'a1 + +val sem_lin_params_rect_Type3 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_lin_params -> 'a1 + +val sem_lin_params_rect_Type2 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_lin_params -> 'a1 + +val sem_lin_params_rect_Type1 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_lin_params -> 'a1 + +val sem_lin_params_rect_Type0 : + (Joint.uns_params -> (__ -> __ Joint_semantics.sem_unserialized_params) -> + (Joint.joint_program -> Joint.joint_closed_internal_function) -> 'a1) -> + sem_lin_params -> 'a1 + +val slp_pars : sem_lin_params -> Joint.uns_params + +val slp_sup0 : sem_lin_params -> 'a1 Joint_semantics.sem_unserialized_params + +val lin_pre_main_generator : + sem_lin_params -> Joint.joint_program -> + Joint.joint_closed_internal_function + +val sem_lin_params_inv_rect_Type4 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_lin_params_inv_rect_Type3 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_lin_params_inv_rect_Type2 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_lin_params_inv_rect_Type1 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_lin_params_inv_rect_Type0 : + sem_lin_params -> (Joint.uns_params -> (__ -> __ + Joint_semantics.sem_unserialized_params) -> (Joint.joint_program -> + Joint.joint_closed_internal_function) -> __ -> 'a1) -> 'a1 + +val sem_lin_params_jmdiscr : sem_lin_params -> sem_lin_params -> __ + +val sem_lin_params_to_lin_params : sem_lin_params -> Joint.lin_params + +val sem_lin_params_to_sem_params : + sem_lin_params -> Joint_semantics.sem_params + +val sem_params_from_sem_lin_params__o__spp' : + sem_lin_params -> Joint_semantics.serialized_params + +val sem_params_from_sem_lin_params__o__spp'__o__msu_pars : + sem_lin_params -> Joint.joint_closed_internal_function + Joint_semantics.sem_unserialized_params + +val sem_params_from_sem_lin_params__o__spp'__o__msu_pars__o__st_pars : + sem_lin_params -> Joint_semantics.sem_state_params + +val sem_params_from_sem_lin_params__o__spp'__o__spp : + sem_lin_params -> Joint.params + +val sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars : + sem_lin_params -> Joint.stmt_params + +val sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars : + sem_lin_params -> Joint.uns_params + +val sem_params_from_sem_lin_params__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + sem_lin_params -> Joint.unserialized_params + +val match_genv_t_rect_Type4 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_rect_Type5 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_rect_Type3 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_rect_Type2 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_rect_Type1 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_rect_Type0 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_inv_rect_Type4 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_inv_rect_Type3 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_inv_rect_Type2 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_inv_rect_Type1 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_inv_rect_Type0 : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val match_genv_t_discr : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> __ + +val match_genv_t_jmdiscr : + AST.matching -> AST.ident List.list -> __ Globalenvs.genv_t -> __ + Globalenvs.genv_t -> __ + +val joint_globalenv : + Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> Joint_semantics.genv + diff --git a/extracted/setoids.ml b/extracted/setoids.ml new file mode 100644 index 0000000..a8ef206 --- /dev/null +++ b/extracted/setoids.ml @@ -0,0 +1,86 @@ +open Preamble + +open Core_notation + +open Pts + +open Hints_declaration + +open Logic + +open Types + +open Relations + +type setoid = +| Mk_Setoid + +(** val setoid_rect_Type4 : + (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 **) +let rec setoid_rect_Type4 h_mk_Setoid = function +| Mk_Setoid -> h_mk_Setoid __ __ __ __ __ + +(** val setoid_rect_Type5 : + (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 **) +let rec setoid_rect_Type5 h_mk_Setoid = function +| Mk_Setoid -> h_mk_Setoid __ __ __ __ __ + +(** val setoid_rect_Type3 : + (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 **) +let rec setoid_rect_Type3 h_mk_Setoid = function +| Mk_Setoid -> h_mk_Setoid __ __ __ __ __ + +(** val setoid_rect_Type2 : + (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 **) +let rec setoid_rect_Type2 h_mk_Setoid = function +| Mk_Setoid -> h_mk_Setoid __ __ __ __ __ + +(** val setoid_rect_Type1 : + (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 **) +let rec setoid_rect_Type1 h_mk_Setoid = function +| Mk_Setoid -> h_mk_Setoid __ __ __ __ __ + +(** val setoid_rect_Type0 : + (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 **) +let rec setoid_rect_Type0 h_mk_Setoid = function +| Mk_Setoid -> h_mk_Setoid __ __ __ __ __ + +type std_supp = __ + +(** val setoid_inv_rect_Type4 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoid_inv_rect_Type4 hterm h1 = + let hcut = setoid_rect_Type4 h1 hterm in hcut __ + +(** val setoid_inv_rect_Type3 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoid_inv_rect_Type3 hterm h1 = + let hcut = setoid_rect_Type3 h1 hterm in hcut __ + +(** val setoid_inv_rect_Type2 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoid_inv_rect_Type2 hterm h1 = + let hcut = setoid_rect_Type2 h1 hterm in hcut __ + +(** val setoid_inv_rect_Type1 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoid_inv_rect_Type1 hterm h1 = + let hcut = setoid_rect_Type1 h1 hterm in hcut __ + +(** val setoid_inv_rect_Type0 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let setoid_inv_rect_Type0 hterm h1 = + let hcut = setoid_rect_Type0 h1 hterm in hcut __ + +(** val as_std : setoid **) +let as_std = + Mk_Setoid + +(** val std_prod : setoid -> setoid -> setoid **) +let std_prod x y = + Mk_Setoid + +(** val std_union : setoid -> setoid -> setoid **) +let std_union x y = + Mk_Setoid + diff --git a/extracted/setoids.mli b/extracted/setoids.mli new file mode 100644 index 0000000..e524263 --- /dev/null +++ b/extracted/setoids.mli @@ -0,0 +1,52 @@ +open Preamble + +open Core_notation + +open Pts + +open Hints_declaration + +open Logic + +open Types + +open Relations + +type setoid = +| Mk_Setoid + +val setoid_rect_Type4 : (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 + +val setoid_rect_Type5 : (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 + +val setoid_rect_Type3 : (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 + +val setoid_rect_Type2 : (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 + +val setoid_rect_Type1 : (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 + +val setoid_rect_Type0 : (__ -> __ -> __ -> __ -> __ -> 'a1) -> setoid -> 'a1 + +type std_supp + +val setoid_inv_rect_Type4 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val setoid_inv_rect_Type3 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val setoid_inv_rect_Type2 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val setoid_inv_rect_Type1 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val setoid_inv_rect_Type0 : + setoid -> (__ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val as_std : setoid + +val std_prod : setoid -> setoid -> setoid + +val std_union : setoid -> setoid -> setoid + diff --git a/extracted/sets.ml b/extracted/sets.ml new file mode 100644 index 0000000..f077cee --- /dev/null +++ b/extracted/sets.ml @@ -0,0 +1,10 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + diff --git a/extracted/sets.mli b/extracted/sets.mli new file mode 100644 index 0000000..f077cee --- /dev/null +++ b/extracted/sets.mli @@ -0,0 +1,10 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + diff --git a/extracted/simplifyCasts.ml b/extracted/simplifyCasts.ml new file mode 100644 index 0000000..dd7afae --- /dev/null +++ b/extracted/simplifyCasts.ml @@ -0,0 +1,722 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open ClassifyOp + +open Smallstep + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open Events + +open IOMonad + +open IO + +open Cexec + +open Casts + +open CexecInd + +open Sets + +open Listb + +open Star + +open Frontend_misc + +(** val reduce_bits : + Nat.nat -> Nat.nat -> Bool.bool -> BitVector.bitVector -> + BitVector.bitVector Types.option **) +let rec reduce_bits n m exp v = + (match n with + | Nat.O -> (fun v0 -> Types.Some v0) + | Nat.S n' -> + (fun v0 -> + match BitVector.eq_b (Vector.head' (Nat.plus n' (Nat.S m)) v0) exp with + | Bool.True -> + reduce_bits n' m exp (Vector.tail (Nat.plus n' (Nat.S m)) v0) + | Bool.False -> Types.None)) v + +(** val pred_bitsize_of_intsize : AST.intsize -> Nat.nat **) +let pred_bitsize_of_intsize sz = + Nat.pred (AST.bitsize_of_intsize sz) + +(** val signed : AST.signedness -> Bool.bool **) +let signed = function +| AST.Signed -> Bool.True +| AST.Unsigned -> Bool.False + +(** val simplify_int : + AST.intsize -> AST.intsize -> AST.signedness -> AST.signedness -> + AST.bvint -> AST.bvint Types.option **) +let rec simplify_int sz sz' sg sg' i = + let bit = + Bool.andb (signed sg) + (Vector.head' + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) + (Nat.times (AST.pred_size_intsize sz) (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))) i) + in + (match Extranat.nat_compare (pred_bitsize_of_intsize sz) + (pred_bitsize_of_intsize sz') with + | Extranat.Nat_lt (x, x0) -> (fun i0 -> Types.None) + | Extranat.Nat_eq x -> (fun i0 -> Types.Some i0) + | Extranat.Nat_gt (x, y) -> + (fun i0 -> + match reduce_bits (Nat.S x) y bit i0 with + | Types.None -> Types.None + | Types.Some i' -> + (match signed sg' with + | Bool.True -> + (match BitVector.eq_b bit (Vector.head' y i') with + | Bool.True -> Types.Some i' + | Bool.False -> Types.None) + | Bool.False -> Types.Some i'))) i + +(** val size_lt_dec : AST.intsize -> AST.intsize -> (__, __) Types.sum **) +let size_lt_dec = function +| AST.I8 -> + (fun clearme0 -> + match clearme0 with + | AST.I8 -> Types.Inr __ + | AST.I16 -> Types.Inl __ + | AST.I32 -> Types.Inl __) +| AST.I16 -> + (fun clearme0 -> + match clearme0 with + | AST.I8 -> Types.Inr __ + | AST.I16 -> Types.Inr __ + | AST.I32 -> Types.Inl __) +| AST.I32 -> + (fun clearme0 -> + match clearme0 with + | AST.I8 -> Types.Inr __ + | AST.I16 -> Types.Inr __ + | AST.I32 -> Types.Inr __) + +(** val size_not_lt_to_ge : + AST.intsize -> AST.intsize -> (__, __) Types.sum **) +let size_not_lt_to_ge clearme sz2 = + (match clearme with + | AST.I8 -> + (fun clearme0 -> + match clearme0 with + | AST.I8 -> (fun _ -> Types.Inl __) + | AST.I16 -> (fun _ -> Types.Inr __) + | AST.I32 -> (fun _ -> Types.Inr __)) + | AST.I16 -> + (fun clearme0 -> + match clearme0 with + | AST.I8 -> (fun _ -> Types.Inr __) + | AST.I16 -> (fun _ -> Types.Inl __) + | AST.I32 -> (fun _ -> Types.Inr __)) + | AST.I32 -> + (fun clearme0 -> + match clearme0 with + | AST.I8 -> (fun _ -> Types.Inr __) + | AST.I16 -> (fun _ -> Types.Inr __) + | AST.I32 -> (fun _ -> Types.Inl __))) sz2 __ + +(** val sign_eq_dect : + AST.signedness -> AST.signedness -> (__, __) Types.sum **) +let sign_eq_dect = function +| AST.Signed -> + (fun clearme0 -> + match clearme0 with + | AST.Signed -> TypeComparison.sg_eq_dec AST.Signed AST.Signed + | AST.Unsigned -> TypeComparison.sg_eq_dec AST.Signed AST.Unsigned) +| AST.Unsigned -> + (fun clearme0 -> + match clearme0 with + | AST.Signed -> TypeComparison.sg_eq_dec AST.Unsigned AST.Signed + | AST.Unsigned -> TypeComparison.sg_eq_dec AST.Unsigned AST.Unsigned) + +(** val necessary_conditions : + AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> + Bool.bool **) +let necessary_conditions src_sz src_sg target_sz target_sg = + match size_lt_dec target_sz src_sz with + | Types.Inl _ -> Bool.True + | Types.Inr _ -> + (match TypeComparison.sz_eq_dec target_sz src_sz with + | Types.Inl _ -> + (match sign_eq_dect src_sg target_sg with + | Types.Inl _ -> Bool.False + | Types.Inr _ -> Bool.True) + | Types.Inr _ -> Bool.False) + +(** val assert_int_value : + Values.val0 Types.option -> AST.intsize -> BitVector.bitVector + Types.option **) +let rec assert_int_value v expected_size = + match v with + | Types.None -> Types.None + | Types.Some v0 -> + (match v0 with + | Values.Vundef -> Types.None + | Values.Vint (sz, i) -> + (match TypeComparison.sz_eq_dec sz expected_size with + | Types.Inl _ -> + Types.Some + (Extralib.eq_rect_Type0_r expected_size (fun i0 -> i0) sz i) + | Types.Inr _ -> Types.None) + | Values.Vnull -> Types.None + | Values.Vptr x -> Types.None) + +(** val binop_simplifiable : Csyntax.binary_operation -> Bool.bool **) +let binop_simplifiable = function +| Csyntax.Oadd -> Bool.True +| Csyntax.Osub -> Bool.True +| Csyntax.Omul -> Bool.False +| Csyntax.Odiv -> Bool.False +| Csyntax.Omod -> Bool.False +| Csyntax.Oand -> Bool.False +| Csyntax.Oor -> Bool.False +| Csyntax.Oxor -> Bool.False +| Csyntax.Oshl -> Bool.False +| Csyntax.Oshr -> Bool.False +| Csyntax.Oeq -> Bool.False +| Csyntax.One -> Bool.False +| Csyntax.Olt -> Bool.False +| Csyntax.Ogt -> Bool.False +| Csyntax.Ole -> Bool.False +| Csyntax.Oge -> Bool.False + +(** val simplify_expr : + Csyntax.expr -> AST.intsize -> AST.signedness -> (Bool.bool, + Csyntax.expr) Types.prod Types.sig0 **) +let rec simplify_expr e target_sz target_sg = + (let Csyntax.Expr (ed, ty) = e in + (fun _ -> + (match ed with + | Csyntax.Econst_int (cst_sz, i) -> + (fun _ -> + (match ty with + | Csyntax.Tvoid -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e }) + | Csyntax.Tint (ty_sz, sg) -> + (fun _ -> + match TypeComparison.sz_eq_dec cst_sz ty_sz with + | Types.Inl _ -> + (match TypeComparison.type_eq_dec ty (Csyntax.Tint (target_sz, + target_sg)) with + | Types.Inl _ -> { Types.fst = Bool.True; Types.snd = e } + | Types.Inr _ -> + (match simplify_int cst_sz target_sz sg target_sg i with + | Types.None -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e }) + | Types.Some i' -> + (fun _ -> { Types.fst = Bool.True; Types.snd = + (Csyntax.Expr ((Csyntax.Econst_int (target_sz, i')), + (Csyntax.Tint (target_sz, target_sg)))) })) __) + | Types.Inr _ -> { Types.fst = Bool.False; Types.snd = e }) + | Csyntax.Tpointer x -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e }) + | Csyntax.Tarray (x, x0) -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e }) + | Csyntax.Tfunction (x, x0) -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e }) + | Csyntax.Tstruct (x, x0) -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e }) + | Csyntax.Tunion (x, x0) -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e }) + | Csyntax.Tcomp_ptr x -> + (fun _ -> { Types.fst = Bool.False; Types.snd = e })) __) + | Csyntax.Evar id -> + (fun _ -> { Types.fst = + (TypeComparison.type_eq ty (Csyntax.Tint (target_sz, target_sg))); + Types.snd = (Csyntax.Expr (ed, ty)) }) + | Csyntax.Ederef e1 -> + (fun _ -> + (let e2 = simplify_inside e1 in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ederef e2), ty)) })) __) + | Csyntax.Eaddrof e1 -> + (fun _ -> + (let e2 = simplify_inside e1 in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Eaddrof e2), ty)) })) __) + | Csyntax.Eunop (op, e1) -> + (fun _ -> + (let e2 = simplify_inside e1 in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Eunop (op, e2)), ty)) })) __) + | Csyntax.Ebinop (op, lhs, rhs) -> + (fun _ -> + (match binop_simplifiable op with + | Bool.True -> + (fun _ -> + match TypeComparison.assert_type_eq ty (Csyntax.typeof lhs) with + | Errors.OK _ -> + (match TypeComparison.assert_type_eq (Csyntax.typeof lhs) + (Csyntax.typeof rhs) with + | Errors.OK _ -> + (let eta2011 = simplify_expr lhs target_sz target_sg in + (fun _ -> + (let { Types.fst = desired_type_lhs; Types.snd = lhs1 } = + eta2011 + in + (fun _ -> + (let eta2010 = simplify_expr rhs target_sz target_sg in + (fun _ -> + (let { Types.fst = desired_type_rhs; Types.snd = + rhs1 } = eta2010 + in + (fun _ -> + (match Bool.andb desired_type_lhs desired_type_rhs with + | Bool.True -> + (fun _ -> { Types.fst = Bool.True; Types.snd = + (Csyntax.Expr ((Csyntax.Ebinop (op, lhs1, rhs1)), + (Csyntax.Tint (target_sz, target_sg)))) }) + | Bool.False -> + (fun _ -> + (let lhs10 = simplify_inside lhs in + (fun _ -> + (let rhs10 = simplify_inside rhs in + (fun _ -> { Types.fst = Bool.False; Types.snd = + (Csyntax.Expr ((Csyntax.Ebinop (op, lhs10, + rhs10)), ty)) })) __)) __)) __)) __)) __)) __)) + __ + | Errors.Error x -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> { Types.fst = Bool.False; Types.snd = + (Csyntax.Expr ((Csyntax.Ebinop (op, lhs1, rhs1)), + ty)) })) __)) __) + | Errors.Error x -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> { Types.fst = Bool.False; Types.snd = + (Csyntax.Expr ((Csyntax.Ebinop (op, lhs1, rhs1)), ty)) })) + __)) __) + | Bool.False -> + (fun _ -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ebinop (op, lhs1, rhs1)), ty)) })) __)) __)) __) + | Csyntax.Ecast (cast_ty, castee) -> + (fun _ -> + (match cast_ty with + | Csyntax.Tvoid -> + (fun _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __) + | Csyntax.Tint (cast_sz, cast_sg) -> + (fun _ -> + match TypeComparison.type_eq_dec ty cast_ty with + | Types.Inl _ -> + (match necessary_conditions cast_sz cast_sg target_sz target_sg with + | Bool.True -> + (fun _ -> + (let eta2013 = simplify_expr castee target_sz target_sg in + (fun _ -> + (let { Types.fst = desired_type; Types.snd = castee1 } = + eta2013 + in + (fun _ -> + (match desired_type with + | Bool.True -> + (fun _ -> { Types.fst = Bool.True; Types.snd = + castee1 }) + | Bool.False -> + (fun _ -> + (let eta2012 = simplify_expr castee cast_sz cast_sg + in + (fun _ -> + (let { Types.fst = desired_type2; Types.snd = + castee2 } = eta2012 + in + (fun _ -> + (match desired_type2 with + | Bool.True -> + (fun _ -> { Types.fst = Bool.False; + Types.snd = castee2 }) + | Bool.False -> + (fun _ -> { Types.fst = Bool.False; + Types.snd = (Csyntax.Expr ((Csyntax.Ecast + (ty, castee2)), cast_ty)) })) __)) __)) __)) + __)) __)) __) + | Bool.False -> + (fun _ -> + (let eta2014 = simplify_expr castee cast_sz cast_sg in + (fun _ -> + (let { Types.fst = desired_type2; Types.snd = + castee2 } = eta2014 + in + (fun _ -> + (match desired_type2 with + | Bool.True -> + (fun _ -> { Types.fst = Bool.False; Types.snd = + castee2 }) + | Bool.False -> + (fun _ -> { Types.fst = Bool.False; Types.snd = + (Csyntax.Expr ((Csyntax.Ecast (ty, castee2)), + cast_ty)) })) __)) __)) __)) __ + | Types.Inr _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __) + | Csyntax.Tpointer x -> + (fun _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __) + | Csyntax.Tarray (x, x0) -> + (fun _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __) + | Csyntax.Tfunction (x, x0) -> + (fun _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __) + | Csyntax.Tstruct (x, x0) -> + (fun _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __) + | Csyntax.Tunion (x, x0) -> + (fun _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __) + | Csyntax.Tcomp_ptr x -> + (fun _ -> + (let castee1 = simplify_inside castee in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecast (cast_ty, castee1)), ty)) })) __)) __) + | Csyntax.Econdition (cond, iftrue, iffalse) -> + (fun _ -> + (let cond1 = simplify_inside cond in + (fun _ -> + match TypeComparison.assert_type_eq ty (Csyntax.typeof iftrue) with + | Errors.OK _ -> + (match TypeComparison.assert_type_eq (Csyntax.typeof iftrue) + (Csyntax.typeof iffalse) with + | Errors.OK _ -> + (let eta2016 = simplify_expr iftrue target_sz target_sg in + (fun _ -> + (let { Types.fst = desired_true; Types.snd = iftrue1 } = + eta2016 + in + (fun _ -> + (let eta2015 = simplify_expr iffalse target_sz target_sg in + (fun _ -> + (let { Types.fst = desired_false; Types.snd = iffalse1 } = + eta2015 + in + (fun _ -> + (match Bool.andb desired_true desired_false with + | Bool.True -> + (fun _ -> { Types.fst = Bool.True; Types.snd = + (Csyntax.Expr ((Csyntax.Econdition (cond1, iftrue1, + iffalse1)), (Csyntax.Tint (target_sz, target_sg)))) }) + | Bool.False -> + (fun _ -> + (let iftrue10 = simplify_inside iftrue in + (fun _ -> + (let iffalse10 = simplify_inside iffalse in + (fun _ -> { Types.fst = Bool.False; Types.snd = + (Csyntax.Expr ((Csyntax.Econdition (cond1, + iftrue10, iffalse10)), ty)) })) __)) __)) __)) __)) + __)) __)) __ + | Errors.Error x -> + (let iftrue1 = simplify_inside iftrue in + (fun _ -> + (let iffalse1 = simplify_inside iffalse in + (fun _ -> { Types.fst = Bool.False; Types.snd = + (Csyntax.Expr ((Csyntax.Econdition (cond1, iftrue1, + iffalse1)), ty)) })) __)) __) + | Errors.Error x -> + (let iftrue1 = simplify_inside iftrue in + (fun _ -> + (let iffalse1 = simplify_inside iffalse in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Econdition (cond1, iftrue1, iffalse1)), ty)) })) __)) + __)) __) + | Csyntax.Eandbool (lhs, rhs) -> + (fun _ -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Eandbool (lhs1, rhs1)), ty)) })) __)) __) + | Csyntax.Eorbool (lhs, rhs) -> + (fun _ -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Eorbool (lhs1, rhs1)), ty)) })) __)) __) + | Csyntax.Esizeof t -> + (fun _ -> { Types.fst = + (TypeComparison.type_eq ty (Csyntax.Tint (target_sz, target_sg))); + Types.snd = (Csyntax.Expr (ed, ty)) }) + | Csyntax.Efield (rec_expr, f) -> + (fun _ -> + (let rec_expr1 = simplify_inside rec_expr in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Efield (rec_expr1, f)), ty)) })) __) + | Csyntax.Ecost (l, e1) -> + (fun _ -> + match TypeComparison.type_eq_dec ty (Csyntax.typeof e1) with + | Types.Inl _ -> + (let eta2017 = simplify_expr e1 target_sz target_sg in + (fun _ -> + (let { Types.fst = desired_type; Types.snd = e2 } = eta2017 in + (fun _ -> { Types.fst = desired_type; Types.snd = (Csyntax.Expr + ((Csyntax.Ecost (l, e2)), (Csyntax.typeof e2))) })) __)) __ + | Types.Inr _ -> + (let e2 = simplify_inside e1 in + (fun _ -> { Types.fst = Bool.False; Types.snd = (Csyntax.Expr + ((Csyntax.Ecost (l, e2)), ty)) })) __)) __)) __ +(** val simplify_inside : Csyntax.expr -> Csyntax.expr Types.sig0 **) +and simplify_inside e = + (let Csyntax.Expr (ed, ty) = e in + (fun _ -> + (match ed with + | Csyntax.Econst_int (x, x0) -> (fun _ -> e) + | Csyntax.Evar x -> (fun _ -> e) + | Csyntax.Ederef e1 -> + (fun _ -> + (let e2 = simplify_inside e1 in + (fun _ -> Csyntax.Expr ((Csyntax.Ederef e2), ty))) __) + | Csyntax.Eaddrof e1 -> + (fun _ -> + (let e2 = simplify_inside e1 in + (fun _ -> Csyntax.Expr ((Csyntax.Eaddrof e2), ty))) __) + | Csyntax.Eunop (op, e1) -> + (fun _ -> + (let e2 = simplify_inside e1 in + (fun _ -> Csyntax.Expr ((Csyntax.Eunop (op, e2)), ty))) __) + | Csyntax.Ebinop (op, lhs, rhs) -> + (fun _ -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> Csyntax.Expr ((Csyntax.Ebinop (op, lhs1, rhs1)), ty))) + __)) __) + | Csyntax.Ecast (cast_ty, castee) -> + (fun _ -> + match TypeComparison.type_eq_dec ty cast_ty with + | Types.Inl _ -> + (match cast_ty with + | Csyntax.Tvoid -> (fun _ -> e) + | Csyntax.Tint (cast_sz, cast_sg) -> + (fun _ -> + (let eta2018 = simplify_expr castee cast_sz cast_sg in + (fun _ -> + (let { Types.fst = success; Types.snd = castee1 } = eta2018 + in + (fun _ -> + (match success with + | Bool.True -> (fun _ -> castee1) + | Bool.False -> + (fun _ -> Csyntax.Expr ((Csyntax.Ecast (cast_ty, + castee1)), ty))) __)) __)) __) + | Csyntax.Tpointer x -> (fun _ -> e) + | Csyntax.Tarray (x, x0) -> (fun _ -> e) + | Csyntax.Tfunction (x, x0) -> (fun _ -> e) + | Csyntax.Tstruct (x, x0) -> (fun _ -> e) + | Csyntax.Tunion (x, x0) -> (fun _ -> e) + | Csyntax.Tcomp_ptr x -> (fun _ -> e)) __ + | Types.Inr _ -> e) + | Csyntax.Econdition (cond, iftrue, iffalse) -> + (fun _ -> + (let cond1 = simplify_inside cond in + (fun _ -> + (let iftrue1 = simplify_inside iftrue in + (fun _ -> + (let iffalse1 = simplify_inside iffalse in + (fun _ -> Csyntax.Expr ((Csyntax.Econdition (cond1, iftrue1, + iffalse1)), ty))) __)) __)) __) + | Csyntax.Eandbool (lhs, rhs) -> + (fun _ -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> Csyntax.Expr ((Csyntax.Eandbool (lhs1, rhs1)), ty))) __)) + __) + | Csyntax.Eorbool (lhs, rhs) -> + (fun _ -> + (let lhs1 = simplify_inside lhs in + (fun _ -> + (let rhs1 = simplify_inside rhs in + (fun _ -> Csyntax.Expr ((Csyntax.Eorbool (lhs1, rhs1)), ty))) __)) + __) + | Csyntax.Esizeof x -> (fun _ -> e) + | Csyntax.Efield (rec_expr, f) -> + (fun _ -> + (let rec_expr1 = simplify_inside rec_expr in + (fun _ -> Csyntax.Expr ((Csyntax.Efield (rec_expr1, f)), ty))) __) + | Csyntax.Ecost (l, e1) -> + (fun _ -> + (let e2 = simplify_inside e1 in + (fun _ -> Csyntax.Expr ((Csyntax.Ecost (l, e2)), ty))) __)) __)) __ + +(** val simplify_e : Csyntax.expr -> Csyntax.expr **) +let simplify_e e = + Types.pi1 (simplify_inside e) + +(** val simplify_statement : Csyntax.statement -> Csyntax.statement **) +let rec simplify_statement = function +| Csyntax.Sskip -> Csyntax.Sskip +| Csyntax.Sassign (e1, e2) -> + Csyntax.Sassign ((simplify_e e1), (simplify_e e2)) +| Csyntax.Scall (eo, e, es) -> + Csyntax.Scall ((Types.option_map simplify_e eo), (simplify_e e), + (List.map simplify_e es)) +| Csyntax.Ssequence (s1, s2) -> + Csyntax.Ssequence ((simplify_statement s1), (simplify_statement s2)) +| Csyntax.Sifthenelse (e, s1, s2) -> + Csyntax.Sifthenelse ((simplify_e e), (simplify_statement s1), + (simplify_statement s2)) +| Csyntax.Swhile (e, s1) -> + Csyntax.Swhile ((simplify_e e), (simplify_statement s1)) +| Csyntax.Sdowhile (e, s1) -> + Csyntax.Sdowhile ((simplify_e e), (simplify_statement s1)) +| Csyntax.Sfor (s1, e, s2, s3) -> + Csyntax.Sfor ((simplify_statement s1), (simplify_e e), + (simplify_statement s2), (simplify_statement s3)) +| Csyntax.Sbreak -> Csyntax.Sbreak +| Csyntax.Scontinue -> Csyntax.Scontinue +| Csyntax.Sreturn eo -> Csyntax.Sreturn (Types.option_map simplify_e eo) +| Csyntax.Sswitch (e, ls) -> + Csyntax.Sswitch ((simplify_e e), (simplify_ls ls)) +| Csyntax.Slabel (l, s1) -> Csyntax.Slabel (l, (simplify_statement s1)) +| Csyntax.Sgoto l -> Csyntax.Sgoto l +| Csyntax.Scost (l, s1) -> Csyntax.Scost (l, (simplify_statement s1)) +(** val simplify_ls : + Csyntax.labeled_statements -> Csyntax.labeled_statements **) +and simplify_ls = function +| Csyntax.LSdefault s -> Csyntax.LSdefault (simplify_statement s) +| Csyntax.LScase (sz, i, s, ls') -> + Csyntax.LScase (sz, i, (simplify_statement s), (simplify_ls ls')) + +(** val simplify_function : Csyntax.function0 -> Csyntax.function0 **) +let simplify_function f = + { Csyntax.fn_return = f.Csyntax.fn_return; Csyntax.fn_params = + f.Csyntax.fn_params; Csyntax.fn_vars = f.Csyntax.fn_vars; + Csyntax.fn_body = (simplify_statement f.Csyntax.fn_body) } + +(** val simplify_fundef : Csyntax.clight_fundef -> Csyntax.clight_fundef **) +let simplify_fundef f = match f with +| Csyntax.CL_Internal f0 -> Csyntax.CL_Internal (simplify_function f0) +| Csyntax.CL_External (x, x0, x1) -> f + +(** val simplify_program : + Csyntax.clight_program -> Csyntax.clight_program **) +let simplify_program p = + AST.transform_program p (fun x -> simplify_fundef) + diff --git a/extracted/simplifyCasts.mli b/extracted/simplifyCasts.mli new file mode 100644 index 0000000..8e0be19 --- /dev/null +++ b/extracted/simplifyCasts.mli @@ -0,0 +1,174 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open ClassifyOp + +open Smallstep + +open Extra_bool + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open SmallstepExec + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open Events + +open IOMonad + +open IO + +open Cexec + +open Casts + +open CexecInd + +open Sets + +open Listb + +open Star + +open Frontend_misc + +val reduce_bits : + Nat.nat -> Nat.nat -> Bool.bool -> BitVector.bitVector -> + BitVector.bitVector Types.option + +val pred_bitsize_of_intsize : AST.intsize -> Nat.nat + +val signed : AST.signedness -> Bool.bool + +val simplify_int : + AST.intsize -> AST.intsize -> AST.signedness -> AST.signedness -> AST.bvint + -> AST.bvint Types.option + +val size_lt_dec : AST.intsize -> AST.intsize -> (__, __) Types.sum + +val size_not_lt_to_ge : AST.intsize -> AST.intsize -> (__, __) Types.sum + +val sign_eq_dect : AST.signedness -> AST.signedness -> (__, __) Types.sum + +val necessary_conditions : + AST.intsize -> AST.signedness -> AST.intsize -> AST.signedness -> Bool.bool + +val assert_int_value : + Values.val0 Types.option -> AST.intsize -> BitVector.bitVector Types.option + +val binop_simplifiable : Csyntax.binary_operation -> Bool.bool + +val simplify_inside : Csyntax.expr -> Csyntax.expr Types.sig0 + +val simplify_expr : + Csyntax.expr -> AST.intsize -> AST.signedness -> (Bool.bool, Csyntax.expr) + Types.prod Types.sig0 + +val simplify_e : Csyntax.expr -> Csyntax.expr + +val simplify_ls : Csyntax.labeled_statements -> Csyntax.labeled_statements + +val simplify_statement : Csyntax.statement -> Csyntax.statement + +val simplify_function : Csyntax.function0 -> Csyntax.function0 + +val simplify_fundef : Csyntax.clight_fundef -> Csyntax.clight_fundef + +val simplify_program : Csyntax.clight_program -> Csyntax.clight_program + diff --git a/extracted/smallstep.ml b/extracted/smallstep.ml new file mode 100644 index 0000000..5878538 --- /dev/null +++ b/extracted/smallstep.ml @@ -0,0 +1,501 @@ +open Preamble + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +type transrel = +| Mk_transrel + +(** val transrel_rect_Type4 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 **) +let rec transrel_rect_Type4 h_mk_transrel = function +| Mk_transrel -> h_mk_transrel __ __ __ + +(** val transrel_rect_Type5 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 **) +let rec transrel_rect_Type5 h_mk_transrel = function +| Mk_transrel -> h_mk_transrel __ __ __ + +(** val transrel_rect_Type3 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 **) +let rec transrel_rect_Type3 h_mk_transrel = function +| Mk_transrel -> h_mk_transrel __ __ __ + +(** val transrel_rect_Type2 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 **) +let rec transrel_rect_Type2 h_mk_transrel = function +| Mk_transrel -> h_mk_transrel __ __ __ + +(** val transrel_rect_Type1 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 **) +let rec transrel_rect_Type1 h_mk_transrel = function +| Mk_transrel -> h_mk_transrel __ __ __ + +(** val transrel_rect_Type0 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 **) +let rec transrel_rect_Type0 h_mk_transrel = function +| Mk_transrel -> h_mk_transrel __ __ __ + +type genv = __ + +type state = __ + +(** val transrel_inv_rect_Type4 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let transrel_inv_rect_Type4 hterm h1 = + let hcut = transrel_rect_Type4 h1 hterm in hcut __ + +(** val transrel_inv_rect_Type3 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let transrel_inv_rect_Type3 hterm h1 = + let hcut = transrel_rect_Type3 h1 hterm in hcut __ + +(** val transrel_inv_rect_Type2 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let transrel_inv_rect_Type2 hterm h1 = + let hcut = transrel_rect_Type2 h1 hterm in hcut __ + +(** val transrel_inv_rect_Type1 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let transrel_inv_rect_Type1 hterm h1 = + let hcut = transrel_rect_Type1 h1 hterm in hcut __ + +(** val transrel_inv_rect_Type0 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let transrel_inv_rect_Type0 hterm h1 = + let hcut = transrel_rect_Type0 h1 hterm in hcut __ + +(** val transrel_jmdiscr : transrel -> transrel -> __ **) +let transrel_jmdiscr x y = + Logic.eq_rect_Type2 x + (let Mk_transrel = x in Obj.magic (fun _ dH -> dH __ __ __)) y + +type program_behavior = +| Terminates of Events.trace * Integers.int +| Diverges of Events.trace +| Reacts of Events.traceinf +| Goes_wrong of Events.trace + +(** val program_behavior_rect_Type4 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 **) +let rec program_behavior_rect_Type4 h_Terminates h_Diverges h_Reacts h_Goes_wrong = function +| Terminates (x_6965, x_6964) -> h_Terminates x_6965 x_6964 +| Diverges x_6966 -> h_Diverges x_6966 +| Reacts x_6967 -> h_Reacts x_6967 +| Goes_wrong x_6968 -> h_Goes_wrong x_6968 + +(** val program_behavior_rect_Type5 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 **) +let rec program_behavior_rect_Type5 h_Terminates h_Diverges h_Reacts h_Goes_wrong = function +| Terminates (x_6975, x_6974) -> h_Terminates x_6975 x_6974 +| Diverges x_6976 -> h_Diverges x_6976 +| Reacts x_6977 -> h_Reacts x_6977 +| Goes_wrong x_6978 -> h_Goes_wrong x_6978 + +(** val program_behavior_rect_Type3 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 **) +let rec program_behavior_rect_Type3 h_Terminates h_Diverges h_Reacts h_Goes_wrong = function +| Terminates (x_6985, x_6984) -> h_Terminates x_6985 x_6984 +| Diverges x_6986 -> h_Diverges x_6986 +| Reacts x_6987 -> h_Reacts x_6987 +| Goes_wrong x_6988 -> h_Goes_wrong x_6988 + +(** val program_behavior_rect_Type2 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 **) +let rec program_behavior_rect_Type2 h_Terminates h_Diverges h_Reacts h_Goes_wrong = function +| Terminates (x_6995, x_6994) -> h_Terminates x_6995 x_6994 +| Diverges x_6996 -> h_Diverges x_6996 +| Reacts x_6997 -> h_Reacts x_6997 +| Goes_wrong x_6998 -> h_Goes_wrong x_6998 + +(** val program_behavior_rect_Type1 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 **) +let rec program_behavior_rect_Type1 h_Terminates h_Diverges h_Reacts h_Goes_wrong = function +| Terminates (x_7005, x_7004) -> h_Terminates x_7005 x_7004 +| Diverges x_7006 -> h_Diverges x_7006 +| Reacts x_7007 -> h_Reacts x_7007 +| Goes_wrong x_7008 -> h_Goes_wrong x_7008 + +(** val program_behavior_rect_Type0 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 **) +let rec program_behavior_rect_Type0 h_Terminates h_Diverges h_Reacts h_Goes_wrong = function +| Terminates (x_7015, x_7014) -> h_Terminates x_7015 x_7014 +| Diverges x_7016 -> h_Diverges x_7016 +| Reacts x_7017 -> h_Reacts x_7017 +| Goes_wrong x_7018 -> h_Goes_wrong x_7018 + +(** val program_behavior_inv_rect_Type4 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 **) +let program_behavior_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = program_behavior_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val program_behavior_inv_rect_Type3 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 **) +let program_behavior_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = program_behavior_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val program_behavior_inv_rect_Type2 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 **) +let program_behavior_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = program_behavior_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val program_behavior_inv_rect_Type1 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 **) +let program_behavior_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = program_behavior_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val program_behavior_inv_rect_Type0 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 **) +let program_behavior_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = program_behavior_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val program_behavior_discr : + program_behavior -> program_behavior -> __ **) +let program_behavior_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Terminates (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Diverges a0 -> Obj.magic (fun _ dH -> dH __) + | Reacts a0 -> Obj.magic (fun _ dH -> dH __) + | Goes_wrong a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val program_behavior_jmdiscr : + program_behavior -> program_behavior -> __ **) +let program_behavior_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Terminates (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Diverges a0 -> Obj.magic (fun _ dH -> dH __) + | Reacts a0 -> Obj.magic (fun _ dH -> dH __) + | Goes_wrong a0 -> Obj.magic (fun _ dH -> dH __)) y + +type semantics = { trans : transrel; ge : __ } + +(** val semantics_rect_Type4 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 **) +let rec semantics_rect_Type4 h_mk_semantics x_7345 = + let { trans = trans0; ge = ge0 } = x_7345 in + h_mk_semantics trans0 __ __ ge0 + +(** val semantics_rect_Type5 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 **) +let rec semantics_rect_Type5 h_mk_semantics x_7347 = + let { trans = trans0; ge = ge0 } = x_7347 in + h_mk_semantics trans0 __ __ ge0 + +(** val semantics_rect_Type3 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 **) +let rec semantics_rect_Type3 h_mk_semantics x_7349 = + let { trans = trans0; ge = ge0 } = x_7349 in + h_mk_semantics trans0 __ __ ge0 + +(** val semantics_rect_Type2 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 **) +let rec semantics_rect_Type2 h_mk_semantics x_7351 = + let { trans = trans0; ge = ge0 } = x_7351 in + h_mk_semantics trans0 __ __ ge0 + +(** val semantics_rect_Type1 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 **) +let rec semantics_rect_Type1 h_mk_semantics x_7353 = + let { trans = trans0; ge = ge0 } = x_7353 in + h_mk_semantics trans0 __ __ ge0 + +(** val semantics_rect_Type0 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 **) +let rec semantics_rect_Type0 h_mk_semantics x_7355 = + let { trans = trans0; ge = ge0 } = x_7355 in + h_mk_semantics trans0 __ __ ge0 + +(** val trans : semantics -> transrel **) +let rec trans xxx = + xxx.trans + +(** val ge : semantics -> __ **) +let rec ge xxx = + xxx.ge + +(** val semantics_inv_rect_Type4 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let semantics_inv_rect_Type4 hterm h1 = + let hcut = semantics_rect_Type4 h1 hterm in hcut __ + +(** val semantics_inv_rect_Type3 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let semantics_inv_rect_Type3 hterm h1 = + let hcut = semantics_rect_Type3 h1 hterm in hcut __ + +(** val semantics_inv_rect_Type2 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let semantics_inv_rect_Type2 hterm h1 = + let hcut = semantics_rect_Type2 h1 hterm in hcut __ + +(** val semantics_inv_rect_Type1 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let semantics_inv_rect_Type1 hterm h1 = + let hcut = semantics_rect_Type1 h1 hterm in hcut __ + +(** val semantics_inv_rect_Type0 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let semantics_inv_rect_Type0 hterm h1 = + let hcut = semantics_rect_Type0 h1 hterm in hcut __ + +(** val semantics_jmdiscr : semantics -> semantics -> __ **) +let semantics_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { trans = a0; ge = a3 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +type related_semantics = { sem1 : semantics; sem2 : semantics } + +(** val related_semantics_rect_Type4 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 **) +let rec related_semantics_rect_Type4 h_mk_related_semantics x_7374 = + let { sem1 = sem3; sem2 = sem4 } = x_7374 in + h_mk_related_semantics sem3 sem4 __ __ __ + +(** val related_semantics_rect_Type5 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 **) +let rec related_semantics_rect_Type5 h_mk_related_semantics x_7376 = + let { sem1 = sem3; sem2 = sem4 } = x_7376 in + h_mk_related_semantics sem3 sem4 __ __ __ + +(** val related_semantics_rect_Type3 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 **) +let rec related_semantics_rect_Type3 h_mk_related_semantics x_7378 = + let { sem1 = sem3; sem2 = sem4 } = x_7378 in + h_mk_related_semantics sem3 sem4 __ __ __ + +(** val related_semantics_rect_Type2 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 **) +let rec related_semantics_rect_Type2 h_mk_related_semantics x_7380 = + let { sem1 = sem3; sem2 = sem4 } = x_7380 in + h_mk_related_semantics sem3 sem4 __ __ __ + +(** val related_semantics_rect_Type1 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 **) +let rec related_semantics_rect_Type1 h_mk_related_semantics x_7382 = + let { sem1 = sem3; sem2 = sem4 } = x_7382 in + h_mk_related_semantics sem3 sem4 __ __ __ + +(** val related_semantics_rect_Type0 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 **) +let rec related_semantics_rect_Type0 h_mk_related_semantics x_7384 = + let { sem1 = sem3; sem2 = sem4 } = x_7384 in + h_mk_related_semantics sem3 sem4 __ __ __ + +(** val sem1 : related_semantics -> semantics **) +let rec sem1 xxx = + xxx.sem1 + +(** val sem2 : related_semantics -> semantics **) +let rec sem2 xxx = + xxx.sem2 + +(** val related_semantics_inv_rect_Type4 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let related_semantics_inv_rect_Type4 hterm h1 = + let hcut = related_semantics_rect_Type4 h1 hterm in hcut __ + +(** val related_semantics_inv_rect_Type3 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let related_semantics_inv_rect_Type3 hterm h1 = + let hcut = related_semantics_rect_Type3 h1 hterm in hcut __ + +(** val related_semantics_inv_rect_Type2 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let related_semantics_inv_rect_Type2 hterm h1 = + let hcut = related_semantics_rect_Type2 h1 hterm in hcut __ + +(** val related_semantics_inv_rect_Type1 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let related_semantics_inv_rect_Type1 hterm h1 = + let hcut = related_semantics_rect_Type1 h1 hterm in hcut __ + +(** val related_semantics_inv_rect_Type0 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 **) +let related_semantics_inv_rect_Type0 hterm h1 = + let hcut = related_semantics_rect_Type0 h1 hterm in hcut __ + +(** val related_semantics_jmdiscr : + related_semantics -> related_semantics -> __ **) +let related_semantics_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { sem1 = a0; sem2 = a1 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +type order_sim = + related_semantics + (* singleton inductive, whose constructor was mk_order_sim *) + +(** val order_sim_rect_Type4 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 **) +let rec order_sim_rect_Type4 h_mk_order_sim x_7405 = + let sem = x_7405 in h_mk_order_sim sem __ __ + +(** val order_sim_rect_Type5 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 **) +let rec order_sim_rect_Type5 h_mk_order_sim x_7407 = + let sem = x_7407 in h_mk_order_sim sem __ __ + +(** val order_sim_rect_Type3 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 **) +let rec order_sim_rect_Type3 h_mk_order_sim x_7409 = + let sem = x_7409 in h_mk_order_sim sem __ __ + +(** val order_sim_rect_Type2 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 **) +let rec order_sim_rect_Type2 h_mk_order_sim x_7411 = + let sem = x_7411 in h_mk_order_sim sem __ __ + +(** val order_sim_rect_Type1 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 **) +let rec order_sim_rect_Type1 h_mk_order_sim x_7413 = + let sem = x_7413 in h_mk_order_sim sem __ __ + +(** val order_sim_rect_Type0 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 **) +let rec order_sim_rect_Type0 h_mk_order_sim x_7415 = + let sem = x_7415 in h_mk_order_sim sem __ __ + +(** val sem : order_sim -> related_semantics **) +let rec sem xxx = + let yyy = xxx in yyy + +(** val order_sim_inv_rect_Type4 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let order_sim_inv_rect_Type4 hterm h1 = + let hcut = order_sim_rect_Type4 h1 hterm in hcut __ + +(** val order_sim_inv_rect_Type3 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let order_sim_inv_rect_Type3 hterm h1 = + let hcut = order_sim_rect_Type3 h1 hterm in hcut __ + +(** val order_sim_inv_rect_Type2 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let order_sim_inv_rect_Type2 hterm h1 = + let hcut = order_sim_rect_Type2 h1 hterm in hcut __ + +(** val order_sim_inv_rect_Type1 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let order_sim_inv_rect_Type1 hterm h1 = + let hcut = order_sim_rect_Type1 h1 hterm in hcut __ + +(** val order_sim_inv_rect_Type0 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let order_sim_inv_rect_Type0 hterm h1 = + let hcut = order_sim_rect_Type0 h1 hterm in hcut __ + +(** val order_sim_jmdiscr : order_sim -> order_sim -> __ **) +let order_sim_jmdiscr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __ __)) y + diff --git a/extracted/smallstep.mli b/extracted/smallstep.mli new file mode 100644 index 0000000..f86f502 --- /dev/null +++ b/extracted/smallstep.mli @@ -0,0 +1,321 @@ +open Preamble + +open CostLabel + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open Values + +open Events + +type transrel = +| Mk_transrel + +val transrel_rect_Type4 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 + +val transrel_rect_Type5 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 + +val transrel_rect_Type3 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 + +val transrel_rect_Type2 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 + +val transrel_rect_Type1 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 + +val transrel_rect_Type0 : (__ -> __ -> __ -> 'a1) -> transrel -> 'a1 + +type genv + +type state + +val transrel_inv_rect_Type4 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val transrel_inv_rect_Type3 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val transrel_inv_rect_Type2 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val transrel_inv_rect_Type1 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val transrel_inv_rect_Type0 : + transrel -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val transrel_jmdiscr : transrel -> transrel -> __ + +type program_behavior = +| Terminates of Events.trace * Integers.int +| Diverges of Events.trace +| Reacts of Events.traceinf +| Goes_wrong of Events.trace + +val program_behavior_rect_Type4 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 + +val program_behavior_rect_Type5 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 + +val program_behavior_rect_Type3 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 + +val program_behavior_rect_Type2 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 + +val program_behavior_rect_Type1 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 + +val program_behavior_rect_Type0 : + (Events.trace -> Integers.int -> 'a1) -> (Events.trace -> 'a1) -> + (Events.traceinf -> 'a1) -> (Events.trace -> 'a1) -> program_behavior -> + 'a1 + +val program_behavior_inv_rect_Type4 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 + +val program_behavior_inv_rect_Type3 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 + +val program_behavior_inv_rect_Type2 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 + +val program_behavior_inv_rect_Type1 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 + +val program_behavior_inv_rect_Type0 : + program_behavior -> (Events.trace -> Integers.int -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> (Events.traceinf -> __ -> 'a1) -> + (Events.trace -> __ -> 'a1) -> 'a1 + +val program_behavior_discr : program_behavior -> program_behavior -> __ + +val program_behavior_jmdiscr : program_behavior -> program_behavior -> __ + +type semantics = { trans : transrel; ge : __ } + +val semantics_rect_Type4 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 + +val semantics_rect_Type5 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 + +val semantics_rect_Type3 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 + +val semantics_rect_Type2 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 + +val semantics_rect_Type1 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 + +val semantics_rect_Type0 : + (transrel -> __ -> __ -> __ -> 'a1) -> semantics -> 'a1 + +val trans : semantics -> transrel + +val ge : semantics -> __ + +val semantics_inv_rect_Type4 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val semantics_inv_rect_Type3 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val semantics_inv_rect_Type2 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val semantics_inv_rect_Type1 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val semantics_inv_rect_Type0 : + semantics -> (transrel -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val semantics_jmdiscr : semantics -> semantics -> __ + +type related_semantics = { sem1 : semantics; sem2 : semantics } + +val related_semantics_rect_Type4 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 + +val related_semantics_rect_Type5 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 + +val related_semantics_rect_Type3 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 + +val related_semantics_rect_Type2 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 + +val related_semantics_rect_Type1 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 + +val related_semantics_rect_Type0 : + (semantics -> semantics -> __ -> __ -> __ -> 'a1) -> related_semantics -> + 'a1 + +val sem1 : related_semantics -> semantics + +val sem2 : related_semantics -> semantics + +val related_semantics_inv_rect_Type4 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val related_semantics_inv_rect_Type3 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val related_semantics_inv_rect_Type2 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val related_semantics_inv_rect_Type1 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val related_semantics_inv_rect_Type0 : + related_semantics -> (semantics -> semantics -> __ -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val related_semantics_jmdiscr : related_semantics -> related_semantics -> __ + +type order_sim = + related_semantics + (* singleton inductive, whose constructor was mk_order_sim *) + +val order_sim_rect_Type4 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 + +val order_sim_rect_Type5 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 + +val order_sim_rect_Type3 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 + +val order_sim_rect_Type2 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 + +val order_sim_rect_Type1 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 + +val order_sim_rect_Type0 : + (related_semantics -> __ -> __ -> 'a1) -> order_sim -> 'a1 + +val sem : order_sim -> related_semantics + +val order_sim_inv_rect_Type4 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 + +val order_sim_inv_rect_Type3 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 + +val order_sim_inv_rect_Type2 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 + +val order_sim_inv_rect_Type1 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 + +val order_sim_inv_rect_Type0 : + order_sim -> (related_semantics -> __ -> __ -> __ -> 'a1) -> 'a1 + +val order_sim_jmdiscr : order_sim -> order_sim -> __ + diff --git a/extracted/smallstepExec.ml b/extracted/smallstepExec.ml new file mode 100644 index 0000000..c76e225 --- /dev/null +++ b/extracted/smallstepExec.ml @@ -0,0 +1,625 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +type ('outty, 'inty) trans_system = { is_final : (__ -> __ -> Integers.int + Types.option); + step : (__ -> __ -> ('outty, 'inty, + (Events.trace, __) Types.prod) + IOMonad.iO) } + +(** val trans_system_rect_Type4 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> + ('a1, 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, + 'a2) trans_system -> 'a3 **) +let rec trans_system_rect_Type4 h_mk_trans_system x_5925 = + let { is_final = is_final0; step = step0 } = x_5925 in + h_mk_trans_system __ __ is_final0 step0 + +(** val trans_system_rect_Type5 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> + ('a1, 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, + 'a2) trans_system -> 'a3 **) +let rec trans_system_rect_Type5 h_mk_trans_system x_5927 = + let { is_final = is_final0; step = step0 } = x_5927 in + h_mk_trans_system __ __ is_final0 step0 + +(** val trans_system_rect_Type3 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> + ('a1, 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, + 'a2) trans_system -> 'a3 **) +let rec trans_system_rect_Type3 h_mk_trans_system x_5929 = + let { is_final = is_final0; step = step0 } = x_5929 in + h_mk_trans_system __ __ is_final0 step0 + +(** val trans_system_rect_Type2 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> + ('a1, 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, + 'a2) trans_system -> 'a3 **) +let rec trans_system_rect_Type2 h_mk_trans_system x_5931 = + let { is_final = is_final0; step = step0 } = x_5931 in + h_mk_trans_system __ __ is_final0 step0 + +(** val trans_system_rect_Type1 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> + ('a1, 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, + 'a2) trans_system -> 'a3 **) +let rec trans_system_rect_Type1 h_mk_trans_system x_5933 = + let { is_final = is_final0; step = step0 } = x_5933 in + h_mk_trans_system __ __ is_final0 step0 + +(** val trans_system_rect_Type0 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> + ('a1, 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, + 'a2) trans_system -> 'a3 **) +let rec trans_system_rect_Type0 h_mk_trans_system x_5935 = + let { is_final = is_final0; step = step0 } = x_5935 in + h_mk_trans_system __ __ is_final0 step0 + +type ('x, 'x0) global = __ + +type ('x, 'x0) state = __ + +(** val is_final : + ('a1, 'a2) trans_system -> __ -> __ -> Integers.int Types.option **) +let rec is_final xxx = + xxx.is_final + +(** val step : + ('a1, 'a2) trans_system -> __ -> __ -> ('a1, 'a2, (Events.trace, __) + Types.prod) IOMonad.iO **) +let rec step xxx = + xxx.step + +(** val trans_system_inv_rect_Type4 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 **) +let trans_system_inv_rect_Type4 hterm h1 = + let hcut = trans_system_rect_Type4 h1 hterm in hcut __ + +(** val trans_system_inv_rect_Type3 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 **) +let trans_system_inv_rect_Type3 hterm h1 = + let hcut = trans_system_rect_Type3 h1 hterm in hcut __ + +(** val trans_system_inv_rect_Type2 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 **) +let trans_system_inv_rect_Type2 hterm h1 = + let hcut = trans_system_rect_Type2 h1 hterm in hcut __ + +(** val trans_system_inv_rect_Type1 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 **) +let trans_system_inv_rect_Type1 hterm h1 = + let hcut = trans_system_rect_Type1 h1 hterm in hcut __ + +(** val trans_system_inv_rect_Type0 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 **) +let trans_system_inv_rect_Type0 hterm h1 = + let hcut = trans_system_rect_Type0 h1 hterm in hcut __ + +(** val repeat : + Nat.nat -> ('a1, 'a2) trans_system -> __ -> __ -> ('a1, 'a2, + (Events.trace, __) Types.prod) IOMonad.iO **) +let rec repeat n exec g s = + match n with + | Nat.O -> IOMonad.Value { Types.fst = Events.e0; Types.snd = s } + | Nat.S n' -> + Obj.magic + (Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (Obj.magic (exec.step g s)) (fun t1 s1 -> + Monad.m_bind2 (Monad.max_def IOMonad.iOMonad) + (Obj.magic (repeat n' exec g s1)) (fun tn sn -> + Obj.magic (IOMonad.Value { Types.fst = (Events.eapp t1 tn); + Types.snd = sn })))) + +(** val trace_map : + ('a1 -> (Events.trace, 'a2) Types.prod Errors.res) -> 'a1 List.list -> + (Events.trace, 'a2 List.list) Types.prod Errors.res **) +let rec trace_map f = function +| List.Nil -> Errors.OK { Types.fst = Events.e0; Types.snd = List.Nil } +| List.Cons (h, t) -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) (Obj.magic f h) (fun tr h' -> + Monad.m_bind2 (Monad.max_def Errors.res0) (Obj.magic (trace_map f t)) + (fun tr' t' -> + Obj.magic (Errors.OK { Types.fst = (Events.eapp tr tr'); Types.snd = + (List.Cons (h', t')) })))) + +type await_value_stuff = { avs_exec : (__, __) trans_system; avs_g : + __; avs_inv : (__ -> Bool.bool) } + +(** val await_value_stuff_rect_Type4 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 **) +let rec await_value_stuff_rect_Type4 h_mk_await_value_stuff x_6097 = + let { avs_exec = avs_exec0; avs_g = avs_g0; avs_inv = avs_inv0 } = x_6097 + in + h_mk_await_value_stuff __ __ avs_exec0 avs_g0 avs_inv0 + +(** val await_value_stuff_rect_Type5 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 **) +let rec await_value_stuff_rect_Type5 h_mk_await_value_stuff x_6099 = + let { avs_exec = avs_exec0; avs_g = avs_g0; avs_inv = avs_inv0 } = x_6099 + in + h_mk_await_value_stuff __ __ avs_exec0 avs_g0 avs_inv0 + +(** val await_value_stuff_rect_Type3 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 **) +let rec await_value_stuff_rect_Type3 h_mk_await_value_stuff x_6101 = + let { avs_exec = avs_exec0; avs_g = avs_g0; avs_inv = avs_inv0 } = x_6101 + in + h_mk_await_value_stuff __ __ avs_exec0 avs_g0 avs_inv0 + +(** val await_value_stuff_rect_Type2 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 **) +let rec await_value_stuff_rect_Type2 h_mk_await_value_stuff x_6103 = + let { avs_exec = avs_exec0; avs_g = avs_g0; avs_inv = avs_inv0 } = x_6103 + in + h_mk_await_value_stuff __ __ avs_exec0 avs_g0 avs_inv0 + +(** val await_value_stuff_rect_Type1 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 **) +let rec await_value_stuff_rect_Type1 h_mk_await_value_stuff x_6105 = + let { avs_exec = avs_exec0; avs_g = avs_g0; avs_inv = avs_inv0 } = x_6105 + in + h_mk_await_value_stuff __ __ avs_exec0 avs_g0 avs_inv0 + +(** val await_value_stuff_rect_Type0 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 **) +let rec await_value_stuff_rect_Type0 h_mk_await_value_stuff x_6107 = + let { avs_exec = avs_exec0; avs_g = avs_g0; avs_inv = avs_inv0 } = x_6107 + in + h_mk_await_value_stuff __ __ avs_exec0 avs_g0 avs_inv0 + +type avs_O = __ + +type avs_I = __ + +(** val avs_exec : await_value_stuff -> (__, __) trans_system **) +let rec avs_exec xxx = + xxx.avs_exec + +(** val avs_g : await_value_stuff -> __ **) +let rec avs_g xxx = + xxx.avs_g + +(** val avs_inv : await_value_stuff -> __ -> Bool.bool **) +let rec avs_inv xxx = + xxx.avs_inv + +(** val await_value_stuff_inv_rect_Type4 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 **) +let await_value_stuff_inv_rect_Type4 hterm h1 = + let hcut = await_value_stuff_rect_Type4 h1 hterm in hcut __ + +(** val await_value_stuff_inv_rect_Type3 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 **) +let await_value_stuff_inv_rect_Type3 hterm h1 = + let hcut = await_value_stuff_rect_Type3 h1 hterm in hcut __ + +(** val await_value_stuff_inv_rect_Type2 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 **) +let await_value_stuff_inv_rect_Type2 hterm h1 = + let hcut = await_value_stuff_rect_Type2 h1 hterm in hcut __ + +(** val await_value_stuff_inv_rect_Type1 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 **) +let await_value_stuff_inv_rect_Type1 hterm h1 = + let hcut = await_value_stuff_rect_Type1 h1 hterm in hcut __ + +(** val await_value_stuff_inv_rect_Type0 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 **) +let await_value_stuff_inv_rect_Type0 hterm h1 = + let hcut = await_value_stuff_rect_Type0 h1 hterm in hcut __ + +type ('state, 'output, 'input) execution = ('state, 'output, 'input) __execution Lazy.t +and ('state, 'output, 'input) __execution = +| E_stop of Events.trace * Integers.int * 'state +| E_step of Events.trace * 'state * ('state, 'output, 'input) execution +| E_wrong of Errors.errmsg +| E_interact of 'output * ('input -> ('state, 'output, 'input) execution) + +(** val execution_inv_rect_Type4 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ + -> 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> + 'a4) -> (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) + execution) -> __ -> 'a4) -> 'a4 **) +let execution_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = + match Lazy.force + hterm with + | E_stop (x, x0, x1) -> h1 x x0 x1 + | E_step (x, x0, x1) -> h2 x x0 x1 + | E_wrong x -> h3 x + | E_interact (x, x0) -> h4 x x0 + in + hcut __ + +(** val execution_inv_rect_Type3 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ + -> 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> + 'a4) -> (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) + execution) -> __ -> 'a4) -> 'a4 **) +let execution_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = + match Lazy.force + hterm with + | E_stop (x, x0, x1) -> h1 x x0 x1 + | E_step (x, x0, x1) -> h2 x x0 x1 + | E_wrong x -> h3 x + | E_interact (x, x0) -> h4 x x0 + in + hcut __ + +(** val execution_inv_rect_Type2 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ + -> 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> + 'a4) -> (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) + execution) -> __ -> 'a4) -> 'a4 **) +let execution_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = + match Lazy.force + hterm with + | E_stop (x, x0, x1) -> h1 x x0 x1 + | E_step (x, x0, x1) -> h2 x x0 x1 + | E_wrong x -> h3 x + | E_interact (x, x0) -> h4 x x0 + in + hcut __ + +(** val execution_inv_rect_Type1 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ + -> 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> + 'a4) -> (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) + execution) -> __ -> 'a4) -> 'a4 **) +let execution_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = + match Lazy.force + hterm with + | E_stop (x, x0, x1) -> h1 x x0 x1 + | E_step (x, x0, x1) -> h2 x x0 x1 + | E_wrong x -> h3 x + | E_interact (x, x0) -> h4 x x0 + in + hcut __ + +(** val execution_inv_rect_Type0 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ + -> 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> + 'a4) -> (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) + execution) -> __ -> 'a4) -> 'a4 **) +let execution_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = + match Lazy.force + hterm with + | E_stop (x, x0, x1) -> h1 x x0 x1 + | E_step (x, x0, x1) -> h2 x x0 x1 + | E_wrong x -> h3 x + | E_interact (x, x0) -> h4 x x0 + in + hcut __ + +(** val execution_discr : + ('a1, 'a2, 'a3) execution -> ('a1, 'a2, 'a3) execution -> __ **) +let execution_discr x y = + Logic.eq_rect_Type2 x + (match Lazy.force + x with + | E_stop (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | E_step (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | E_wrong a0 -> Obj.magic (fun _ dH -> dH __) + | E_interact (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val execution_jmdiscr : + ('a1, 'a2, 'a3) execution -> ('a1, 'a2, 'a3) execution -> __ **) +let execution_jmdiscr x y = + Logic.eq_rect_Type2 x + (match Lazy.force + x with + | E_stop (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | E_step (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | E_wrong a0 -> Obj.magic (fun _ dH -> dH __) + | E_interact (a0, a10) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val exec_inf_aux : + ('a1, 'a2) trans_system -> __ -> ('a1, 'a2, (Events.trace, __) + Types.prod) IOMonad.iO -> (__, 'a1, 'a2) execution **) +let rec exec_inf_aux exec g = function +| IOMonad.Interact (out, k') -> + lazy (E_interact (out, (fun v -> exec_inf_aux exec g (k' v)))) +| IOMonad.Value v -> + let { Types.fst = t; Types.snd = s' } = v in + (match exec.is_final g s' with + | Types.None -> + lazy (E_step (t, s', (exec_inf_aux exec g (exec.step g s')))) + | Types.Some r -> lazy (E_stop (t, r, s'))) +| IOMonad.Wrong m -> lazy (E_wrong m) + +type ('outty, 'inty) fullexec = { es1 : ('outty, 'inty) trans_system; + make_global : (__ -> __); + make_initial_state : (__ -> __ Errors.res) } + +(** val fullexec_rect_Type4 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 **) +let rec fullexec_rect_Type4 h_mk_fullexec x_6125 = + let { es1 = es2; make_global = make_global0; make_initial_state = + make_initial_state0 } = x_6125 + in + h_mk_fullexec __ es2 make_global0 make_initial_state0 + +(** val fullexec_rect_Type5 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 **) +let rec fullexec_rect_Type5 h_mk_fullexec x_6127 = + let { es1 = es2; make_global = make_global0; make_initial_state = + make_initial_state0 } = x_6127 + in + h_mk_fullexec __ es2 make_global0 make_initial_state0 + +(** val fullexec_rect_Type3 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 **) +let rec fullexec_rect_Type3 h_mk_fullexec x_6129 = + let { es1 = es2; make_global = make_global0; make_initial_state = + make_initial_state0 } = x_6129 + in + h_mk_fullexec __ es2 make_global0 make_initial_state0 + +(** val fullexec_rect_Type2 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 **) +let rec fullexec_rect_Type2 h_mk_fullexec x_6131 = + let { es1 = es2; make_global = make_global0; make_initial_state = + make_initial_state0 } = x_6131 + in + h_mk_fullexec __ es2 make_global0 make_initial_state0 + +(** val fullexec_rect_Type1 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 **) +let rec fullexec_rect_Type1 h_mk_fullexec x_6133 = + let { es1 = es2; make_global = make_global0; make_initial_state = + make_initial_state0 } = x_6133 + in + h_mk_fullexec __ es2 make_global0 make_initial_state0 + +(** val fullexec_rect_Type0 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 **) +let rec fullexec_rect_Type0 h_mk_fullexec x_6135 = + let { es1 = es2; make_global = make_global0; make_initial_state = + make_initial_state0 } = x_6135 + in + h_mk_fullexec __ es2 make_global0 make_initial_state0 + +type ('x, 'x0) program = __ + +(** val es1 : ('a1, 'a2) fullexec -> ('a1, 'a2) trans_system **) +let rec es1 xxx = + xxx.es1 + +(** val make_global : ('a1, 'a2) fullexec -> __ -> __ **) +let rec make_global xxx = + xxx.make_global + +(** val make_initial_state : ('a1, 'a2) fullexec -> __ -> __ Errors.res **) +let rec make_initial_state xxx = + xxx.make_initial_state + +(** val fullexec_inv_rect_Type4 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> + (__ -> __ Errors.res) -> __ -> 'a3) -> 'a3 **) +let fullexec_inv_rect_Type4 hterm h1 = + let hcut = fullexec_rect_Type4 h1 hterm in hcut __ + +(** val fullexec_inv_rect_Type3 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> + (__ -> __ Errors.res) -> __ -> 'a3) -> 'a3 **) +let fullexec_inv_rect_Type3 hterm h1 = + let hcut = fullexec_rect_Type3 h1 hterm in hcut __ + +(** val fullexec_inv_rect_Type2 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> + (__ -> __ Errors.res) -> __ -> 'a3) -> 'a3 **) +let fullexec_inv_rect_Type2 hterm h1 = + let hcut = fullexec_rect_Type2 h1 hterm in hcut __ + +(** val fullexec_inv_rect_Type1 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> + (__ -> __ Errors.res) -> __ -> 'a3) -> 'a3 **) +let fullexec_inv_rect_Type1 hterm h1 = + let hcut = fullexec_rect_Type1 h1 hterm in hcut __ + +(** val fullexec_inv_rect_Type0 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> + (__ -> __ Errors.res) -> __ -> 'a3) -> 'a3 **) +let fullexec_inv_rect_Type0 hterm h1 = + let hcut = fullexec_rect_Type0 h1 hterm in hcut __ + +(** val exec_inf : ('a1, 'a2) fullexec -> __ -> (__, 'a1, 'a2) execution **) +let exec_inf fx p = + match fx.make_initial_state p with + | Errors.OK s -> + exec_inf_aux fx.es1 (fx.make_global p) (IOMonad.Value { Types.fst = + Events.e0; Types.snd = s }) + | Errors.Error m -> lazy (E_wrong m) + +type 'x execution_prefix = (Events.trace, 'x) Types.prod List.list + +(** val split_trace : + ('a3, 'a1, 'a2) execution -> Nat.nat -> ('a3 execution_prefix, ('a3, 'a1, + 'a2) execution) Types.prod Types.option **) +let rec split_trace x = function +| Nat.O -> Types.Some { Types.fst = List.Nil; Types.snd = x } +| Nat.S n' -> + (match Lazy.force + x with + | E_stop (tr, r, s) -> + (match n' with + | Nat.O -> + Types.Some { Types.fst = (List.Cons ({ Types.fst = tr; Types.snd = + s }, List.Nil)); Types.snd = x } + | Nat.S x0 -> Types.None) + | E_step (tr, s, x') -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Option.option) + (Obj.magic (split_trace x' n')) (fun pre x'' -> + Obj.magic (Types.Some { Types.fst = (List.Cons ({ Types.fst = tr; + Types.snd = s }, pre)); Types.snd = x'' }))) + | E_wrong x0 -> Types.None + | E_interact (x0, x1) -> Types.None) + +(** val exec_steps : + Nat.nat -> ('a1, 'a2) fullexec -> __ -> __ -> ((__, Events.trace) + Types.prod List.list, __) Types.prod Errors.res **) +let rec exec_steps n fx g s = + match n with + | Nat.O -> + Obj.magic + (Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = List.Nil; + Types.snd = s }) + | Nat.S m -> + (match fx.es1.is_final g s with + | Types.None -> + (match fx.es1.step g s with + | IOMonad.Interact (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.UnexpectedIO) + | IOMonad.Value trs -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (exec_steps m fx g trs.Types.snd)) (fun tl s' -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (List.Cons ({ Types.fst = s; Types.snd = trs.Types.fst }, + tl)); Types.snd = s' })) + | IOMonad.Wrong m0 -> Errors.Error m0) + | Types.Some r -> + Errors.Error (Errors.msg ErrorMessages.TerminatedEarly)) + +(** val gather_trace : + ('a1, Events.trace) Types.prod List.list -> Events.trace **) +let rec gather_trace = function +| List.Nil -> Events.e0 +| List.Cons (h, t) -> Events.eapp h.Types.snd (gather_trace t) + +(** val switch_trace_aux : + Events.trace -> ('a1, Events.trace) Types.prod List.list -> 'a1 -> + (Events.trace, 'a1) Types.prod List.list **) +let rec switch_trace_aux tr l s' = + match l with + | List.Nil -> List.Cons ({ Types.fst = tr; Types.snd = s' }, List.Nil) + | List.Cons (h, t) -> + List.Cons ({ Types.fst = tr; Types.snd = h.Types.fst }, + (switch_trace_aux h.Types.snd t s')) + +(** val switch_trace : + ('a1, Events.trace) Types.prod List.list -> 'a1 -> (Events.trace, 'a1) + Types.prod List.list **) +let switch_trace l s' = + match l with + | List.Nil -> List.Nil + | List.Cons (h, t) -> switch_trace_aux h.Types.snd t s' + diff --git a/extracted/smallstepExec.mli b/extracted/smallstepExec.mli new file mode 100644 index 0000000..2129756 --- /dev/null +++ b/extracted/smallstepExec.mli @@ -0,0 +1,350 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Extralib + +open Proper + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open IOMonad + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open CostLabel + +open PositiveMap + +open Deqsets + +open Lists + +open Identifiers + +open AST + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +type ('outty, 'inty) trans_system = { is_final : (__ -> __ -> Integers.int + Types.option); + step : (__ -> __ -> ('outty, 'inty, + (Events.trace, __) Types.prod) + IOMonad.iO) } + +val trans_system_rect_Type4 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> ('a1, + 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, 'a2) + trans_system -> 'a3 + +val trans_system_rect_Type5 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> ('a1, + 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, 'a2) + trans_system -> 'a3 + +val trans_system_rect_Type3 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> ('a1, + 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, 'a2) + trans_system -> 'a3 + +val trans_system_rect_Type2 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> ('a1, + 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, 'a2) + trans_system -> 'a3 + +val trans_system_rect_Type1 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> ('a1, + 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, 'a2) + trans_system -> 'a3 + +val trans_system_rect_Type0 : + (__ -> __ -> (__ -> __ -> Integers.int Types.option) -> (__ -> __ -> ('a1, + 'a2, (Events.trace, __) Types.prod) IOMonad.iO) -> 'a3) -> ('a1, 'a2) + trans_system -> 'a3 + +type ('outty, 'inty) global + +type ('outty, 'inty) state + +val is_final : + ('a1, 'a2) trans_system -> __ -> __ -> Integers.int Types.option + +val step : + ('a1, 'a2) trans_system -> __ -> __ -> ('a1, 'a2, (Events.trace, __) + Types.prod) IOMonad.iO + +val trans_system_inv_rect_Type4 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 + +val trans_system_inv_rect_Type3 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 + +val trans_system_inv_rect_Type2 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 + +val trans_system_inv_rect_Type1 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 + +val trans_system_inv_rect_Type0 : + ('a1, 'a2) trans_system -> (__ -> __ -> (__ -> __ -> Integers.int + Types.option) -> (__ -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO) -> __ -> 'a3) -> 'a3 + +val repeat : + Nat.nat -> ('a1, 'a2) trans_system -> __ -> __ -> ('a1, 'a2, (Events.trace, + __) Types.prod) IOMonad.iO + +val trace_map : + ('a1 -> (Events.trace, 'a2) Types.prod Errors.res) -> 'a1 List.list -> + (Events.trace, 'a2 List.list) Types.prod Errors.res + +type await_value_stuff = { avs_exec : (__, __) trans_system; avs_g : + __; avs_inv : (__ -> Bool.bool) } + +val await_value_stuff_rect_Type4 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 + +val await_value_stuff_rect_Type5 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 + +val await_value_stuff_rect_Type3 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 + +val await_value_stuff_rect_Type2 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 + +val await_value_stuff_rect_Type1 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 + +val await_value_stuff_rect_Type0 : + (__ -> __ -> (__, __) trans_system -> __ -> (__ -> Bool.bool) -> 'a1) -> + await_value_stuff -> 'a1 + +type avs_O + +type avs_I + +val avs_exec : await_value_stuff -> (__, __) trans_system + +val avs_g : await_value_stuff -> __ + +val avs_inv : await_value_stuff -> __ -> Bool.bool + +val await_value_stuff_inv_rect_Type4 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 + +val await_value_stuff_inv_rect_Type3 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 + +val await_value_stuff_inv_rect_Type2 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 + +val await_value_stuff_inv_rect_Type1 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 + +val await_value_stuff_inv_rect_Type0 : + await_value_stuff -> (__ -> __ -> (__, __) trans_system -> __ -> (__ -> + Bool.bool) -> __ -> 'a1) -> 'a1 + +type ('state, 'output, 'input) execution = ('state, 'output, 'input) __execution Lazy.t +and ('state, 'output, 'input) __execution = +| E_stop of Events.trace * Integers.int * 'state +| E_step of Events.trace * 'state * ('state, 'output, 'input) execution +| E_wrong of Errors.errmsg +| E_interact of 'output * ('input -> ('state, 'output, 'input) execution) + +val execution_inv_rect_Type4 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ -> + 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> 'a4) -> + (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) execution) + -> __ -> 'a4) -> 'a4 + +val execution_inv_rect_Type3 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ -> + 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> 'a4) -> + (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) execution) + -> __ -> 'a4) -> 'a4 + +val execution_inv_rect_Type2 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ -> + 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> 'a4) -> + (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) execution) + -> __ -> 'a4) -> 'a4 + +val execution_inv_rect_Type1 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ -> + 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> 'a4) -> + (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) execution) + -> __ -> 'a4) -> 'a4 + +val execution_inv_rect_Type0 : + ('a1, 'a2, 'a3) execution -> (Events.trace -> Integers.int -> 'a1 -> __ -> + 'a4) -> (Events.trace -> 'a1 -> ('a1, 'a2, 'a3) execution -> __ -> 'a4) -> + (Errors.errmsg -> __ -> 'a4) -> ('a2 -> ('a3 -> ('a1, 'a2, 'a3) execution) + -> __ -> 'a4) -> 'a4 + +val execution_discr : + ('a1, 'a2, 'a3) execution -> ('a1, 'a2, 'a3) execution -> __ + +val execution_jmdiscr : + ('a1, 'a2, 'a3) execution -> ('a1, 'a2, 'a3) execution -> __ + +val exec_inf_aux : + ('a1, 'a2) trans_system -> __ -> ('a1, 'a2, (Events.trace, __) Types.prod) + IOMonad.iO -> (__, 'a1, 'a2) execution + +type ('outty, 'inty) fullexec = { es1 : ('outty, 'inty) trans_system; + make_global : (__ -> __); + make_initial_state : (__ -> __ Errors.res) } + +val fullexec_rect_Type4 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 + +val fullexec_rect_Type5 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 + +val fullexec_rect_Type3 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 + +val fullexec_rect_Type2 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 + +val fullexec_rect_Type1 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 + +val fullexec_rect_Type0 : + (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ -> __ Errors.res) -> + 'a3) -> ('a1, 'a2) fullexec -> 'a3 + +type ('outty, 'inty) program + +val es1 : ('a1, 'a2) fullexec -> ('a1, 'a2) trans_system + +val make_global : ('a1, 'a2) fullexec -> __ -> __ + +val make_initial_state : ('a1, 'a2) fullexec -> __ -> __ Errors.res + +val fullexec_inv_rect_Type4 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ + -> __ Errors.res) -> __ -> 'a3) -> 'a3 + +val fullexec_inv_rect_Type3 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ + -> __ Errors.res) -> __ -> 'a3) -> 'a3 + +val fullexec_inv_rect_Type2 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ + -> __ Errors.res) -> __ -> 'a3) -> 'a3 + +val fullexec_inv_rect_Type1 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ + -> __ Errors.res) -> __ -> 'a3) -> 'a3 + +val fullexec_inv_rect_Type0 : + ('a1, 'a2) fullexec -> (__ -> ('a1, 'a2) trans_system -> (__ -> __) -> (__ + -> __ Errors.res) -> __ -> 'a3) -> 'a3 + +val exec_inf : ('a1, 'a2) fullexec -> __ -> (__, 'a1, 'a2) execution + +type 'x execution_prefix = (Events.trace, 'x) Types.prod List.list + +val split_trace : + ('a3, 'a1, 'a2) execution -> Nat.nat -> ('a3 execution_prefix, ('a3, 'a1, + 'a2) execution) Types.prod Types.option + +val exec_steps : + Nat.nat -> ('a1, 'a2) fullexec -> __ -> __ -> ((__, Events.trace) + Types.prod List.list, __) Types.prod Errors.res + +val gather_trace : ('a1, Events.trace) Types.prod List.list -> Events.trace + +val switch_trace_aux : + Events.trace -> ('a1, Events.trace) Types.prod List.list -> 'a1 -> + (Events.trace, 'a1) Types.prod List.list + +val switch_trace : + ('a1, Events.trace) Types.prod List.list -> 'a1 -> (Events.trace, 'a1) + Types.prod List.list + diff --git a/extracted/stacksize.ml b/extracted/stacksize.ml new file mode 100644 index 0000000..aa4f612 --- /dev/null +++ b/extracted/stacksize.ml @@ -0,0 +1,311 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Hide + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Russell + +open Util + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open Jmeq + +open StructuredTraces + +type call_ud = +| Up of AST.ident +| Down of AST.ident + +(** val call_ud_rect_Type4 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 **) +let rec call_ud_rect_Type4 h_up h_down = function +| Up x_23575 -> h_up x_23575 +| Down x_23576 -> h_down x_23576 + +(** val call_ud_rect_Type5 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 **) +let rec call_ud_rect_Type5 h_up h_down = function +| Up x_23580 -> h_up x_23580 +| Down x_23581 -> h_down x_23581 + +(** val call_ud_rect_Type3 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 **) +let rec call_ud_rect_Type3 h_up h_down = function +| Up x_23585 -> h_up x_23585 +| Down x_23586 -> h_down x_23586 + +(** val call_ud_rect_Type2 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 **) +let rec call_ud_rect_Type2 h_up h_down = function +| Up x_23590 -> h_up x_23590 +| Down x_23591 -> h_down x_23591 + +(** val call_ud_rect_Type1 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 **) +let rec call_ud_rect_Type1 h_up h_down = function +| Up x_23595 -> h_up x_23595 +| Down x_23596 -> h_down x_23596 + +(** val call_ud_rect_Type0 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 **) +let rec call_ud_rect_Type0 h_up h_down = function +| Up x_23600 -> h_up x_23600 +| Down x_23601 -> h_down x_23601 + +(** val call_ud_inv_rect_Type4 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let call_ud_inv_rect_Type4 hterm h1 h2 = + let hcut = call_ud_rect_Type4 h1 h2 hterm in hcut __ + +(** val call_ud_inv_rect_Type3 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let call_ud_inv_rect_Type3 hterm h1 h2 = + let hcut = call_ud_rect_Type3 h1 h2 hterm in hcut __ + +(** val call_ud_inv_rect_Type2 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let call_ud_inv_rect_Type2 hterm h1 h2 = + let hcut = call_ud_rect_Type2 h1 h2 hterm in hcut __ + +(** val call_ud_inv_rect_Type1 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let call_ud_inv_rect_Type1 hterm h1 h2 = + let hcut = call_ud_rect_Type1 h1 h2 hterm in hcut __ + +(** val call_ud_inv_rect_Type0 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 **) +let call_ud_inv_rect_Type0 hterm h1 h2 = + let hcut = call_ud_rect_Type0 h1 h2 hterm in hcut __ + +(** val call_ud_discr : call_ud -> call_ud -> __ **) +let call_ud_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Up a0 -> Obj.magic (fun _ dH -> dH __) + | Down a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val call_ud_jmdiscr : call_ud -> call_ud -> __ **) +let call_ud_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Up a0 -> Obj.magic (fun _ dH -> dH __) + | Down a0 -> Obj.magic (fun _ dH -> dH __)) y + +type stacksize_info = { current : Nat.nat; maximum : Nat.nat } + +(** val stacksize_info_rect_Type4 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 **) +let rec stacksize_info_rect_Type4 h_mk_stacksize_info x_23636 = + let { current = current0; maximum = maximum0 } = x_23636 in + h_mk_stacksize_info current0 maximum0 + +(** val stacksize_info_rect_Type5 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 **) +let rec stacksize_info_rect_Type5 h_mk_stacksize_info x_23638 = + let { current = current0; maximum = maximum0 } = x_23638 in + h_mk_stacksize_info current0 maximum0 + +(** val stacksize_info_rect_Type3 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 **) +let rec stacksize_info_rect_Type3 h_mk_stacksize_info x_23640 = + let { current = current0; maximum = maximum0 } = x_23640 in + h_mk_stacksize_info current0 maximum0 + +(** val stacksize_info_rect_Type2 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 **) +let rec stacksize_info_rect_Type2 h_mk_stacksize_info x_23642 = + let { current = current0; maximum = maximum0 } = x_23642 in + h_mk_stacksize_info current0 maximum0 + +(** val stacksize_info_rect_Type1 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 **) +let rec stacksize_info_rect_Type1 h_mk_stacksize_info x_23644 = + let { current = current0; maximum = maximum0 } = x_23644 in + h_mk_stacksize_info current0 maximum0 + +(** val stacksize_info_rect_Type0 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 **) +let rec stacksize_info_rect_Type0 h_mk_stacksize_info x_23646 = + let { current = current0; maximum = maximum0 } = x_23646 in + h_mk_stacksize_info current0 maximum0 + +(** val current : stacksize_info -> Nat.nat **) +let rec current xxx = + xxx.current + +(** val maximum : stacksize_info -> Nat.nat **) +let rec maximum xxx = + xxx.maximum + +(** val stacksize_info_inv_rect_Type4 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let stacksize_info_inv_rect_Type4 hterm h1 = + let hcut = stacksize_info_rect_Type4 h1 hterm in hcut __ + +(** val stacksize_info_inv_rect_Type3 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let stacksize_info_inv_rect_Type3 hterm h1 = + let hcut = stacksize_info_rect_Type3 h1 hterm in hcut __ + +(** val stacksize_info_inv_rect_Type2 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let stacksize_info_inv_rect_Type2 hterm h1 = + let hcut = stacksize_info_rect_Type2 h1 hterm in hcut __ + +(** val stacksize_info_inv_rect_Type1 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let stacksize_info_inv_rect_Type1 hterm h1 = + let hcut = stacksize_info_rect_Type1 h1 hterm in hcut __ + +(** val stacksize_info_inv_rect_Type0 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 **) +let stacksize_info_inv_rect_Type0 hterm h1 = + let hcut = stacksize_info_rect_Type0 h1 hterm in hcut __ + +(** val stacksize_info_discr : stacksize_info -> stacksize_info -> __ **) +let stacksize_info_discr x y = + Logic.eq_rect_Type2 x + (let { current = a0; maximum = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val stacksize_info_jmdiscr : stacksize_info -> stacksize_info -> __ **) +let stacksize_info_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { current = a0; maximum = a1 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val update_stacksize_info : + (AST.ident -> Nat.nat Types.option) -> stacksize_info -> call_ud + List.list -> stacksize_info **) +let update_stacksize_info stacksizes = + let get_stacksize = fun f -> + match stacksizes f with + | Types.None -> Nat.O + | Types.Some n -> n + in + let f = fun ud acc -> + match ud with + | Up i -> + let new_stack = Nat.plus (get_stacksize i) acc.current in + let new_max = Nat.max acc.maximum new_stack in + { current = new_stack; maximum = new_max } + | Down i -> + let new_stack = Nat.minus acc.current (get_stacksize i) in + { current = new_stack; maximum = acc.maximum } + in + List.foldr f + +(** val extract_call_ud_from_observables : + StructuredTraces.intensional_event List.list -> call_ud List.list **) +let extract_call_ud_from_observables = + let f = fun ev -> + match ev with + | StructuredTraces.IEVcost x -> List.Nil + | StructuredTraces.IEVcall i -> List.Cons ((Up i), List.Nil) + | StructuredTraces.IEVtailcall (i, j) -> + List.Cons ((Down i), (List.Cons ((Up j), List.Nil))) + | StructuredTraces.IEVret i -> List.Cons ((Down i), List.Nil) + in + List.foldr (fun ev -> List.append (f ev)) List.Nil + +(** val extract_call_ud_from_tlr : + StructuredTraces.abstract_status -> __ -> __ -> + StructuredTraces.trace_label_return -> AST.ident -> call_ud List.list **) +let extract_call_ud_from_tlr s st1 st2 tlr curr = + extract_call_ud_from_observables + (Types.pi1 + (StructuredTraces.observables_trace_label_return s st1 st2 tlr curr)) + +(** val extract_call_ud_from_tll : + StructuredTraces.trace_ends_with_ret -> StructuredTraces.abstract_status + -> __ -> __ -> StructuredTraces.trace_label_label -> AST.ident -> call_ud + List.list **) +let extract_call_ud_from_tll s fl st1 st2 tll curr = + extract_call_ud_from_observables + (Types.pi1 + (StructuredTraces.observables_trace_label_label fl s st1 st2 tll curr)) + diff --git a/extracted/stacksize.mli b/extracted/stacksize.mli new file mode 100644 index 0000000..2fb05b3 --- /dev/null +++ b/extracted/stacksize.mli @@ -0,0 +1,198 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Hide + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Sets + +open Listb + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Russell + +open Util + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open Jmeq + +open StructuredTraces + +type call_ud = +| Up of AST.ident +| Down of AST.ident + +val call_ud_rect_Type4 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 + +val call_ud_rect_Type5 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 + +val call_ud_rect_Type3 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 + +val call_ud_rect_Type2 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 + +val call_ud_rect_Type1 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 + +val call_ud_rect_Type0 : + (AST.ident -> 'a1) -> (AST.ident -> 'a1) -> call_ud -> 'a1 + +val call_ud_inv_rect_Type4 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val call_ud_inv_rect_Type3 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val call_ud_inv_rect_Type2 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val call_ud_inv_rect_Type1 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val call_ud_inv_rect_Type0 : + call_ud -> (AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> 'a1) -> 'a1 + +val call_ud_discr : call_ud -> call_ud -> __ + +val call_ud_jmdiscr : call_ud -> call_ud -> __ + +type stacksize_info = { current : Nat.nat; maximum : Nat.nat } + +val stacksize_info_rect_Type4 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 + +val stacksize_info_rect_Type5 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 + +val stacksize_info_rect_Type3 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 + +val stacksize_info_rect_Type2 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 + +val stacksize_info_rect_Type1 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 + +val stacksize_info_rect_Type0 : + (Nat.nat -> Nat.nat -> 'a1) -> stacksize_info -> 'a1 + +val current : stacksize_info -> Nat.nat + +val maximum : stacksize_info -> Nat.nat + +val stacksize_info_inv_rect_Type4 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 + +val stacksize_info_inv_rect_Type3 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 + +val stacksize_info_inv_rect_Type2 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 + +val stacksize_info_inv_rect_Type1 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 + +val stacksize_info_inv_rect_Type0 : + stacksize_info -> (Nat.nat -> Nat.nat -> __ -> 'a1) -> 'a1 + +val stacksize_info_discr : stacksize_info -> stacksize_info -> __ + +val stacksize_info_jmdiscr : stacksize_info -> stacksize_info -> __ + +val update_stacksize_info : + (AST.ident -> Nat.nat Types.option) -> stacksize_info -> call_ud List.list + -> stacksize_info + +val extract_call_ud_from_observables : + StructuredTraces.intensional_event List.list -> call_ud List.list + +val extract_call_ud_from_tlr : + StructuredTraces.abstract_status -> __ -> __ -> + StructuredTraces.trace_label_return -> AST.ident -> call_ud List.list + +val extract_call_ud_from_tll : + StructuredTraces.trace_ends_with_ret -> StructuredTraces.abstract_status -> + __ -> __ -> StructuredTraces.trace_label_label -> AST.ident -> call_ud + List.list + diff --git a/extracted/star.ml b/extracted/star.ml new file mode 100644 index 0000000..07e66b0 --- /dev/null +++ b/extracted/star.ml @@ -0,0 +1,12 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + diff --git a/extracted/star.mli b/extracted/star.mli new file mode 100644 index 0000000..07e66b0 --- /dev/null +++ b/extracted/star.mli @@ -0,0 +1,12 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + diff --git a/extracted/state.ml b/extracted/state.ml new file mode 100644 index 0000000..532dd6c --- /dev/null +++ b/extracted/state.ml @@ -0,0 +1,58 @@ +open Preamble + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Monad + +(** val state_monad : Monad.setoidMonadProps **) +let state_monad = + Monad.makeSetoidMonadProps (fun _ x s -> { Types.fst = s; Types.snd = x }) + (fun _ _ m f s -> let { Types.fst = s'; Types.snd = x } = m s in f x s') + +(** val state_get : 'a1 Monad.smax_def__o__monad **) +let state_get = + Obj.magic (fun s -> { Types.fst = s; Types.snd = s }) + +(** val state_set : 'a1 -> Types.unit0 Monad.smax_def__o__monad **) +let state_set s = + Obj.magic (fun x -> { Types.fst = s; Types.snd = Types.It }) + +(** val state_run : 'a1 -> 'a2 Monad.smax_def__o__monad -> 'a2 **) +let state_run s c = + (Obj.magic c s).Types.snd + +(** val state_update : + ('a1 -> 'a1) -> Types.unit0 Monad.smax_def__o__monad **) +let state_update f = + Obj.magic (fun s -> { Types.fst = (f s); Types.snd = Types.It }) + +(** val state_pred : Monad.monadPred **) +let state_pred = + Monad.Mk_MonadPred + +(** val stateRel : Monad.monadRel **) +let stateRel = + Monad.Mk_MonadRel + diff --git a/extracted/state.mli b/extracted/state.mli new file mode 100644 index 0000000..b84d0d6 --- /dev/null +++ b/extracted/state.mli @@ -0,0 +1,42 @@ +open Preamble + +open Jmeq + +open Russell + +open Bool + +open Nat + +open List + +open Setoids + +open Relations + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Monad + +val state_monad : Monad.setoidMonadProps + +val state_get : 'a1 Monad.smax_def__o__monad + +val state_set : 'a1 -> Types.unit0 Monad.smax_def__o__monad + +val state_run : 'a1 -> 'a2 Monad.smax_def__o__monad -> 'a2 + +val state_update : ('a1 -> 'a1) -> Types.unit0 Monad.smax_def__o__monad + +val state_pred : Monad.monadPred + +val stateRel : Monad.monadRel + diff --git a/extracted/status.ml b/extracted/status.ml new file mode 100644 index 0000000..7a08f70 --- /dev/null +++ b/extracted/status.ml @@ -0,0 +1,4176 @@ +open Preamble + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +type time = Nat.nat + +type serialBufferType = +| Eight of BitVector.byte +| Nine of BitVector.bit * BitVector.byte + +(** val serialBufferType_rect_Type4 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 **) +let rec serialBufferType_rect_Type4 h_Eight h_Nine = function +| Eight x_21722 -> h_Eight x_21722 +| Nine (x_21724, x_21723) -> h_Nine x_21724 x_21723 + +(** val serialBufferType_rect_Type5 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 **) +let rec serialBufferType_rect_Type5 h_Eight h_Nine = function +| Eight x_21728 -> h_Eight x_21728 +| Nine (x_21730, x_21729) -> h_Nine x_21730 x_21729 + +(** val serialBufferType_rect_Type3 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 **) +let rec serialBufferType_rect_Type3 h_Eight h_Nine = function +| Eight x_21734 -> h_Eight x_21734 +| Nine (x_21736, x_21735) -> h_Nine x_21736 x_21735 + +(** val serialBufferType_rect_Type2 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 **) +let rec serialBufferType_rect_Type2 h_Eight h_Nine = function +| Eight x_21740 -> h_Eight x_21740 +| Nine (x_21742, x_21741) -> h_Nine x_21742 x_21741 + +(** val serialBufferType_rect_Type1 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 **) +let rec serialBufferType_rect_Type1 h_Eight h_Nine = function +| Eight x_21746 -> h_Eight x_21746 +| Nine (x_21748, x_21747) -> h_Nine x_21748 x_21747 + +(** val serialBufferType_rect_Type0 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 **) +let rec serialBufferType_rect_Type0 h_Eight h_Nine = function +| Eight x_21752 -> h_Eight x_21752 +| Nine (x_21754, x_21753) -> h_Nine x_21754 x_21753 + +(** val serialBufferType_inv_rect_Type4 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 **) +let serialBufferType_inv_rect_Type4 hterm h1 h2 = + let hcut = serialBufferType_rect_Type4 h1 h2 hterm in hcut __ + +(** val serialBufferType_inv_rect_Type3 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 **) +let serialBufferType_inv_rect_Type3 hterm h1 h2 = + let hcut = serialBufferType_rect_Type3 h1 h2 hterm in hcut __ + +(** val serialBufferType_inv_rect_Type2 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 **) +let serialBufferType_inv_rect_Type2 hterm h1 h2 = + let hcut = serialBufferType_rect_Type2 h1 h2 hterm in hcut __ + +(** val serialBufferType_inv_rect_Type1 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 **) +let serialBufferType_inv_rect_Type1 hterm h1 h2 = + let hcut = serialBufferType_rect_Type1 h1 h2 hterm in hcut __ + +(** val serialBufferType_inv_rect_Type0 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 **) +let serialBufferType_inv_rect_Type0 hterm h1 h2 = + let hcut = serialBufferType_rect_Type0 h1 h2 hterm in hcut __ + +(** val serialBufferType_discr : + serialBufferType -> serialBufferType -> __ **) +let serialBufferType_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Eight a0 -> Obj.magic (fun _ dH -> dH __) + | Nine (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val serialBufferType_jmdiscr : + serialBufferType -> serialBufferType -> __ **) +let serialBufferType_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Eight a0 -> Obj.magic (fun _ dH -> dH __) + | Nine (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +type lineType = +| P1 of BitVector.byte +| P3 of BitVector.byte +| SerialBuffer of serialBufferType + +(** val lineType_rect_Type4 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType + -> 'a1) -> lineType -> 'a1 **) +let rec lineType_rect_Type4 h_P1 h_P3 h_SerialBuffer = function +| P1 x_21801 -> h_P1 x_21801 +| P3 x_21802 -> h_P3 x_21802 +| SerialBuffer x_21803 -> h_SerialBuffer x_21803 + +(** val lineType_rect_Type5 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType + -> 'a1) -> lineType -> 'a1 **) +let rec lineType_rect_Type5 h_P1 h_P3 h_SerialBuffer = function +| P1 x_21808 -> h_P1 x_21808 +| P3 x_21809 -> h_P3 x_21809 +| SerialBuffer x_21810 -> h_SerialBuffer x_21810 + +(** val lineType_rect_Type3 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType + -> 'a1) -> lineType -> 'a1 **) +let rec lineType_rect_Type3 h_P1 h_P3 h_SerialBuffer = function +| P1 x_21815 -> h_P1 x_21815 +| P3 x_21816 -> h_P3 x_21816 +| SerialBuffer x_21817 -> h_SerialBuffer x_21817 + +(** val lineType_rect_Type2 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType + -> 'a1) -> lineType -> 'a1 **) +let rec lineType_rect_Type2 h_P1 h_P3 h_SerialBuffer = function +| P1 x_21822 -> h_P1 x_21822 +| P3 x_21823 -> h_P3 x_21823 +| SerialBuffer x_21824 -> h_SerialBuffer x_21824 + +(** val lineType_rect_Type1 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType + -> 'a1) -> lineType -> 'a1 **) +let rec lineType_rect_Type1 h_P1 h_P3 h_SerialBuffer = function +| P1 x_21829 -> h_P1 x_21829 +| P3 x_21830 -> h_P3 x_21830 +| SerialBuffer x_21831 -> h_SerialBuffer x_21831 + +(** val lineType_rect_Type0 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType + -> 'a1) -> lineType -> 'a1 **) +let rec lineType_rect_Type0 h_P1 h_P3 h_SerialBuffer = function +| P1 x_21836 -> h_P1 x_21836 +| P3 x_21837 -> h_P3 x_21837 +| SerialBuffer x_21838 -> h_SerialBuffer x_21838 + +(** val lineType_inv_rect_Type4 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (serialBufferType -> __ -> 'a1) -> 'a1 **) +let lineType_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = lineType_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val lineType_inv_rect_Type3 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (serialBufferType -> __ -> 'a1) -> 'a1 **) +let lineType_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = lineType_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val lineType_inv_rect_Type2 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (serialBufferType -> __ -> 'a1) -> 'a1 **) +let lineType_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = lineType_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val lineType_inv_rect_Type1 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (serialBufferType -> __ -> 'a1) -> 'a1 **) +let lineType_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = lineType_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val lineType_inv_rect_Type0 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> + 'a1) -> (serialBufferType -> __ -> 'a1) -> 'a1 **) +let lineType_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = lineType_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val lineType_discr : lineType -> lineType -> __ **) +let lineType_discr x y = + Logic.eq_rect_Type2 x + (match x with + | P1 a0 -> Obj.magic (fun _ dH -> dH __) + | P3 a0 -> Obj.magic (fun _ dH -> dH __) + | SerialBuffer a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val lineType_jmdiscr : lineType -> lineType -> __ **) +let lineType_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | P1 a0 -> Obj.magic (fun _ dH -> dH __) + | P3 a0 -> Obj.magic (fun _ dH -> dH __) + | SerialBuffer a0 -> Obj.magic (fun _ dH -> dH __)) y + +type sFR8051 = +| SFR_SP +| SFR_DPL +| SFR_DPH +| SFR_PCON +| SFR_TCON +| SFR_TMOD +| SFR_TL0 +| SFR_TL1 +| SFR_TH0 +| SFR_TH1 +| SFR_P1 +| SFR_SCON +| SFR_SBUF +| SFR_IE +| SFR_P3 +| SFR_IP +| SFR_PSW +| SFR_ACC_A +| SFR_ACC_B + +(** val sFR8051_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 **) +let rec sFR8051_rect_Type4 h_SFR_SP h_SFR_DPL h_SFR_DPH h_SFR_PCON h_SFR_TCON h_SFR_TMOD h_SFR_TL0 h_SFR_TL1 h_SFR_TH0 h_SFR_TH1 h_SFR_P1 h_SFR_SCON h_SFR_SBUF h_SFR_IE h_SFR_P3 h_SFR_IP h_SFR_PSW h_SFR_ACC_A h_SFR_ACC_B = function +| SFR_SP -> h_SFR_SP +| SFR_DPL -> h_SFR_DPL +| SFR_DPH -> h_SFR_DPH +| SFR_PCON -> h_SFR_PCON +| SFR_TCON -> h_SFR_TCON +| SFR_TMOD -> h_SFR_TMOD +| SFR_TL0 -> h_SFR_TL0 +| SFR_TL1 -> h_SFR_TL1 +| SFR_TH0 -> h_SFR_TH0 +| SFR_TH1 -> h_SFR_TH1 +| SFR_P1 -> h_SFR_P1 +| SFR_SCON -> h_SFR_SCON +| SFR_SBUF -> h_SFR_SBUF +| SFR_IE -> h_SFR_IE +| SFR_P3 -> h_SFR_P3 +| SFR_IP -> h_SFR_IP +| SFR_PSW -> h_SFR_PSW +| SFR_ACC_A -> h_SFR_ACC_A +| SFR_ACC_B -> h_SFR_ACC_B + +(** val sFR8051_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 **) +let rec sFR8051_rect_Type5 h_SFR_SP h_SFR_DPL h_SFR_DPH h_SFR_PCON h_SFR_TCON h_SFR_TMOD h_SFR_TL0 h_SFR_TL1 h_SFR_TH0 h_SFR_TH1 h_SFR_P1 h_SFR_SCON h_SFR_SBUF h_SFR_IE h_SFR_P3 h_SFR_IP h_SFR_PSW h_SFR_ACC_A h_SFR_ACC_B = function +| SFR_SP -> h_SFR_SP +| SFR_DPL -> h_SFR_DPL +| SFR_DPH -> h_SFR_DPH +| SFR_PCON -> h_SFR_PCON +| SFR_TCON -> h_SFR_TCON +| SFR_TMOD -> h_SFR_TMOD +| SFR_TL0 -> h_SFR_TL0 +| SFR_TL1 -> h_SFR_TL1 +| SFR_TH0 -> h_SFR_TH0 +| SFR_TH1 -> h_SFR_TH1 +| SFR_P1 -> h_SFR_P1 +| SFR_SCON -> h_SFR_SCON +| SFR_SBUF -> h_SFR_SBUF +| SFR_IE -> h_SFR_IE +| SFR_P3 -> h_SFR_P3 +| SFR_IP -> h_SFR_IP +| SFR_PSW -> h_SFR_PSW +| SFR_ACC_A -> h_SFR_ACC_A +| SFR_ACC_B -> h_SFR_ACC_B + +(** val sFR8051_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 **) +let rec sFR8051_rect_Type3 h_SFR_SP h_SFR_DPL h_SFR_DPH h_SFR_PCON h_SFR_TCON h_SFR_TMOD h_SFR_TL0 h_SFR_TL1 h_SFR_TH0 h_SFR_TH1 h_SFR_P1 h_SFR_SCON h_SFR_SBUF h_SFR_IE h_SFR_P3 h_SFR_IP h_SFR_PSW h_SFR_ACC_A h_SFR_ACC_B = function +| SFR_SP -> h_SFR_SP +| SFR_DPL -> h_SFR_DPL +| SFR_DPH -> h_SFR_DPH +| SFR_PCON -> h_SFR_PCON +| SFR_TCON -> h_SFR_TCON +| SFR_TMOD -> h_SFR_TMOD +| SFR_TL0 -> h_SFR_TL0 +| SFR_TL1 -> h_SFR_TL1 +| SFR_TH0 -> h_SFR_TH0 +| SFR_TH1 -> h_SFR_TH1 +| SFR_P1 -> h_SFR_P1 +| SFR_SCON -> h_SFR_SCON +| SFR_SBUF -> h_SFR_SBUF +| SFR_IE -> h_SFR_IE +| SFR_P3 -> h_SFR_P3 +| SFR_IP -> h_SFR_IP +| SFR_PSW -> h_SFR_PSW +| SFR_ACC_A -> h_SFR_ACC_A +| SFR_ACC_B -> h_SFR_ACC_B + +(** val sFR8051_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 **) +let rec sFR8051_rect_Type2 h_SFR_SP h_SFR_DPL h_SFR_DPH h_SFR_PCON h_SFR_TCON h_SFR_TMOD h_SFR_TL0 h_SFR_TL1 h_SFR_TH0 h_SFR_TH1 h_SFR_P1 h_SFR_SCON h_SFR_SBUF h_SFR_IE h_SFR_P3 h_SFR_IP h_SFR_PSW h_SFR_ACC_A h_SFR_ACC_B = function +| SFR_SP -> h_SFR_SP +| SFR_DPL -> h_SFR_DPL +| SFR_DPH -> h_SFR_DPH +| SFR_PCON -> h_SFR_PCON +| SFR_TCON -> h_SFR_TCON +| SFR_TMOD -> h_SFR_TMOD +| SFR_TL0 -> h_SFR_TL0 +| SFR_TL1 -> h_SFR_TL1 +| SFR_TH0 -> h_SFR_TH0 +| SFR_TH1 -> h_SFR_TH1 +| SFR_P1 -> h_SFR_P1 +| SFR_SCON -> h_SFR_SCON +| SFR_SBUF -> h_SFR_SBUF +| SFR_IE -> h_SFR_IE +| SFR_P3 -> h_SFR_P3 +| SFR_IP -> h_SFR_IP +| SFR_PSW -> h_SFR_PSW +| SFR_ACC_A -> h_SFR_ACC_A +| SFR_ACC_B -> h_SFR_ACC_B + +(** val sFR8051_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 **) +let rec sFR8051_rect_Type1 h_SFR_SP h_SFR_DPL h_SFR_DPH h_SFR_PCON h_SFR_TCON h_SFR_TMOD h_SFR_TL0 h_SFR_TL1 h_SFR_TH0 h_SFR_TH1 h_SFR_P1 h_SFR_SCON h_SFR_SBUF h_SFR_IE h_SFR_P3 h_SFR_IP h_SFR_PSW h_SFR_ACC_A h_SFR_ACC_B = function +| SFR_SP -> h_SFR_SP +| SFR_DPL -> h_SFR_DPL +| SFR_DPH -> h_SFR_DPH +| SFR_PCON -> h_SFR_PCON +| SFR_TCON -> h_SFR_TCON +| SFR_TMOD -> h_SFR_TMOD +| SFR_TL0 -> h_SFR_TL0 +| SFR_TL1 -> h_SFR_TL1 +| SFR_TH0 -> h_SFR_TH0 +| SFR_TH1 -> h_SFR_TH1 +| SFR_P1 -> h_SFR_P1 +| SFR_SCON -> h_SFR_SCON +| SFR_SBUF -> h_SFR_SBUF +| SFR_IE -> h_SFR_IE +| SFR_P3 -> h_SFR_P3 +| SFR_IP -> h_SFR_IP +| SFR_PSW -> h_SFR_PSW +| SFR_ACC_A -> h_SFR_ACC_A +| SFR_ACC_B -> h_SFR_ACC_B + +(** val sFR8051_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 **) +let rec sFR8051_rect_Type0 h_SFR_SP h_SFR_DPL h_SFR_DPH h_SFR_PCON h_SFR_TCON h_SFR_TMOD h_SFR_TL0 h_SFR_TL1 h_SFR_TH0 h_SFR_TH1 h_SFR_P1 h_SFR_SCON h_SFR_SBUF h_SFR_IE h_SFR_P3 h_SFR_IP h_SFR_PSW h_SFR_ACC_A h_SFR_ACC_B = function +| SFR_SP -> h_SFR_SP +| SFR_DPL -> h_SFR_DPL +| SFR_DPH -> h_SFR_DPH +| SFR_PCON -> h_SFR_PCON +| SFR_TCON -> h_SFR_TCON +| SFR_TMOD -> h_SFR_TMOD +| SFR_TL0 -> h_SFR_TL0 +| SFR_TL1 -> h_SFR_TL1 +| SFR_TH0 -> h_SFR_TH0 +| SFR_TH1 -> h_SFR_TH1 +| SFR_P1 -> h_SFR_P1 +| SFR_SCON -> h_SFR_SCON +| SFR_SBUF -> h_SFR_SBUF +| SFR_IE -> h_SFR_IE +| SFR_P3 -> h_SFR_P3 +| SFR_IP -> h_SFR_IP +| SFR_PSW -> h_SFR_PSW +| SFR_ACC_A -> h_SFR_ACC_A +| SFR_ACC_B -> h_SFR_ACC_B + +(** val sFR8051_inv_rect_Type4 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let sFR8051_inv_rect_Type4 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + sFR8051_rect_Type4 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val sFR8051_inv_rect_Type3 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let sFR8051_inv_rect_Type3 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + sFR8051_rect_Type3 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val sFR8051_inv_rect_Type2 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let sFR8051_inv_rect_Type2 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + sFR8051_rect_Type2 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val sFR8051_inv_rect_Type1 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let sFR8051_inv_rect_Type1 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + sFR8051_rect_Type1 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val sFR8051_inv_rect_Type0 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> + 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let sFR8051_inv_rect_Type0 hterm h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 h17 h18 h19 = + let hcut = + sFR8051_rect_Type0 h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11 h12 h13 h14 h15 h16 + h17 h18 h19 hterm + in + hcut __ + +(** val sFR8051_discr : sFR8051 -> sFR8051 -> __ **) +let sFR8051_discr x y = + Logic.eq_rect_Type2 x + (match x with + | SFR_SP -> Obj.magic (fun _ dH -> dH) + | SFR_DPL -> Obj.magic (fun _ dH -> dH) + | SFR_DPH -> Obj.magic (fun _ dH -> dH) + | SFR_PCON -> Obj.magic (fun _ dH -> dH) + | SFR_TCON -> Obj.magic (fun _ dH -> dH) + | SFR_TMOD -> Obj.magic (fun _ dH -> dH) + | SFR_TL0 -> Obj.magic (fun _ dH -> dH) + | SFR_TL1 -> Obj.magic (fun _ dH -> dH) + | SFR_TH0 -> Obj.magic (fun _ dH -> dH) + | SFR_TH1 -> Obj.magic (fun _ dH -> dH) + | SFR_P1 -> Obj.magic (fun _ dH -> dH) + | SFR_SCON -> Obj.magic (fun _ dH -> dH) + | SFR_SBUF -> Obj.magic (fun _ dH -> dH) + | SFR_IE -> Obj.magic (fun _ dH -> dH) + | SFR_P3 -> Obj.magic (fun _ dH -> dH) + | SFR_IP -> Obj.magic (fun _ dH -> dH) + | SFR_PSW -> Obj.magic (fun _ dH -> dH) + | SFR_ACC_A -> Obj.magic (fun _ dH -> dH) + | SFR_ACC_B -> Obj.magic (fun _ dH -> dH)) y + +(** val sFR8051_jmdiscr : sFR8051 -> sFR8051 -> __ **) +let sFR8051_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | SFR_SP -> Obj.magic (fun _ dH -> dH) + | SFR_DPL -> Obj.magic (fun _ dH -> dH) + | SFR_DPH -> Obj.magic (fun _ dH -> dH) + | SFR_PCON -> Obj.magic (fun _ dH -> dH) + | SFR_TCON -> Obj.magic (fun _ dH -> dH) + | SFR_TMOD -> Obj.magic (fun _ dH -> dH) + | SFR_TL0 -> Obj.magic (fun _ dH -> dH) + | SFR_TL1 -> Obj.magic (fun _ dH -> dH) + | SFR_TH0 -> Obj.magic (fun _ dH -> dH) + | SFR_TH1 -> Obj.magic (fun _ dH -> dH) + | SFR_P1 -> Obj.magic (fun _ dH -> dH) + | SFR_SCON -> Obj.magic (fun _ dH -> dH) + | SFR_SBUF -> Obj.magic (fun _ dH -> dH) + | SFR_IE -> Obj.magic (fun _ dH -> dH) + | SFR_P3 -> Obj.magic (fun _ dH -> dH) + | SFR_IP -> Obj.magic (fun _ dH -> dH) + | SFR_PSW -> Obj.magic (fun _ dH -> dH) + | SFR_ACC_A -> Obj.magic (fun _ dH -> dH) + | SFR_ACC_B -> Obj.magic (fun _ dH -> dH)) y + +(** val sfr_8051_index : sFR8051 -> Nat.nat **) +let sfr_8051_index = function +| SFR_SP -> Nat.O +| SFR_DPL -> Nat.S Nat.O +| SFR_DPH -> Nat.S (Nat.S Nat.O) +| SFR_PCON -> Nat.S (Nat.S (Nat.S Nat.O)) +| SFR_TCON -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O))) +| SFR_TMOD -> Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) +| SFR_TL0 -> Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) +| SFR_TL1 -> Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))) +| SFR_TH0 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))) +| SFR_TH1 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))) +| SFR_P1 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) +| SFR_SCON -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))) +| SFR_SBUF -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))) +| SFR_IE -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))))))) +| SFR_P3 -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))) +| SFR_IP -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))) +| SFR_PSW -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))) +| SFR_ACC_A -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))))))))))) +| SFR_ACC_B -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))) + +type sFR8052 = +| SFR_T2CON +| SFR_RCAP2L +| SFR_RCAP2H +| SFR_TL2 +| SFR_TH2 + +(** val sFR8052_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 **) +let rec sFR8052_rect_Type4 h_SFR_T2CON h_SFR_RCAP2L h_SFR_RCAP2H h_SFR_TL2 h_SFR_TH2 = function +| SFR_T2CON -> h_SFR_T2CON +| SFR_RCAP2L -> h_SFR_RCAP2L +| SFR_RCAP2H -> h_SFR_RCAP2H +| SFR_TL2 -> h_SFR_TL2 +| SFR_TH2 -> h_SFR_TH2 + +(** val sFR8052_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 **) +let rec sFR8052_rect_Type5 h_SFR_T2CON h_SFR_RCAP2L h_SFR_RCAP2H h_SFR_TL2 h_SFR_TH2 = function +| SFR_T2CON -> h_SFR_T2CON +| SFR_RCAP2L -> h_SFR_RCAP2L +| SFR_RCAP2H -> h_SFR_RCAP2H +| SFR_TL2 -> h_SFR_TL2 +| SFR_TH2 -> h_SFR_TH2 + +(** val sFR8052_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 **) +let rec sFR8052_rect_Type3 h_SFR_T2CON h_SFR_RCAP2L h_SFR_RCAP2H h_SFR_TL2 h_SFR_TH2 = function +| SFR_T2CON -> h_SFR_T2CON +| SFR_RCAP2L -> h_SFR_RCAP2L +| SFR_RCAP2H -> h_SFR_RCAP2H +| SFR_TL2 -> h_SFR_TL2 +| SFR_TH2 -> h_SFR_TH2 + +(** val sFR8052_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 **) +let rec sFR8052_rect_Type2 h_SFR_T2CON h_SFR_RCAP2L h_SFR_RCAP2H h_SFR_TL2 h_SFR_TH2 = function +| SFR_T2CON -> h_SFR_T2CON +| SFR_RCAP2L -> h_SFR_RCAP2L +| SFR_RCAP2H -> h_SFR_RCAP2H +| SFR_TL2 -> h_SFR_TL2 +| SFR_TH2 -> h_SFR_TH2 + +(** val sFR8052_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 **) +let rec sFR8052_rect_Type1 h_SFR_T2CON h_SFR_RCAP2L h_SFR_RCAP2H h_SFR_TL2 h_SFR_TH2 = function +| SFR_T2CON -> h_SFR_T2CON +| SFR_RCAP2L -> h_SFR_RCAP2L +| SFR_RCAP2H -> h_SFR_RCAP2H +| SFR_TL2 -> h_SFR_TL2 +| SFR_TH2 -> h_SFR_TH2 + +(** val sFR8052_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 **) +let rec sFR8052_rect_Type0 h_SFR_T2CON h_SFR_RCAP2L h_SFR_RCAP2H h_SFR_TL2 h_SFR_TH2 = function +| SFR_T2CON -> h_SFR_T2CON +| SFR_RCAP2L -> h_SFR_RCAP2L +| SFR_RCAP2H -> h_SFR_RCAP2H +| SFR_TL2 -> h_SFR_TL2 +| SFR_TH2 -> h_SFR_TH2 + +(** val sFR8052_inv_rect_Type4 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let sFR8052_inv_rect_Type4 hterm h1 h2 h3 h4 h5 = + let hcut = sFR8052_rect_Type4 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val sFR8052_inv_rect_Type3 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let sFR8052_inv_rect_Type3 hterm h1 h2 h3 h4 h5 = + let hcut = sFR8052_rect_Type3 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val sFR8052_inv_rect_Type2 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let sFR8052_inv_rect_Type2 hterm h1 h2 h3 h4 h5 = + let hcut = sFR8052_rect_Type2 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val sFR8052_inv_rect_Type1 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let sFR8052_inv_rect_Type1 hterm h1 h2 h3 h4 h5 = + let hcut = sFR8052_rect_Type1 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val sFR8052_inv_rect_Type0 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 **) +let sFR8052_inv_rect_Type0 hterm h1 h2 h3 h4 h5 = + let hcut = sFR8052_rect_Type0 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val sFR8052_discr : sFR8052 -> sFR8052 -> __ **) +let sFR8052_discr x y = + Logic.eq_rect_Type2 x + (match x with + | SFR_T2CON -> Obj.magic (fun _ dH -> dH) + | SFR_RCAP2L -> Obj.magic (fun _ dH -> dH) + | SFR_RCAP2H -> Obj.magic (fun _ dH -> dH) + | SFR_TL2 -> Obj.magic (fun _ dH -> dH) + | SFR_TH2 -> Obj.magic (fun _ dH -> dH)) y + +(** val sFR8052_jmdiscr : sFR8052 -> sFR8052 -> __ **) +let sFR8052_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | SFR_T2CON -> Obj.magic (fun _ dH -> dH) + | SFR_RCAP2L -> Obj.magic (fun _ dH -> dH) + | SFR_RCAP2H -> Obj.magic (fun _ dH -> dH) + | SFR_TL2 -> Obj.magic (fun _ dH -> dH) + | SFR_TH2 -> Obj.magic (fun _ dH -> dH)) y + +(** val sfr_8052_index : sFR8052 -> Nat.nat **) +let sfr_8052_index = function +| SFR_T2CON -> Nat.O +| SFR_RCAP2L -> Nat.S Nat.O +| SFR_RCAP2H -> Nat.S (Nat.S Nat.O) +| SFR_TL2 -> Nat.S (Nat.S (Nat.S Nat.O)) +| SFR_TH2 -> Nat.S (Nat.S (Nat.S (Nat.S Nat.O))) + +type 'm preStatus = { low_internal_ram : BitVector.byte + BitVectorTrie.bitVectorTrie; + high_internal_ram : BitVector.byte + BitVectorTrie.bitVectorTrie; + external_ram : BitVector.byte + BitVectorTrie.bitVectorTrie; + program_counter : BitVector.word; + special_function_registers_8051 : BitVector.byte + Vector.vector; + special_function_registers_8052 : BitVector.byte + Vector.vector; + p1_latch : BitVector.byte; p3_latch : BitVector.byte; + clock : time } + +(** val preStatus_rect_Type4 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 **) +let rec preStatus_rect_Type4 code_memory h_mk_PreStatus x_22224 = + let { low_internal_ram = low_internal_ram0; high_internal_ram = + high_internal_ram0; external_ram = external_ram0; program_counter = + program_counter0; special_function_registers_8051 = + special_function_registers_8053; special_function_registers_8052 = + special_function_registers_8054; p1_latch = p1_latch0; p3_latch = + p3_latch0; clock = clock0 } = x_22224 + in + h_mk_PreStatus low_internal_ram0 high_internal_ram0 external_ram0 + program_counter0 special_function_registers_8053 + special_function_registers_8054 p1_latch0 p3_latch0 clock0 + +(** val preStatus_rect_Type5 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 **) +let rec preStatus_rect_Type5 code_memory h_mk_PreStatus x_22226 = + let { low_internal_ram = low_internal_ram0; high_internal_ram = + high_internal_ram0; external_ram = external_ram0; program_counter = + program_counter0; special_function_registers_8051 = + special_function_registers_8053; special_function_registers_8052 = + special_function_registers_8054; p1_latch = p1_latch0; p3_latch = + p3_latch0; clock = clock0 } = x_22226 + in + h_mk_PreStatus low_internal_ram0 high_internal_ram0 external_ram0 + program_counter0 special_function_registers_8053 + special_function_registers_8054 p1_latch0 p3_latch0 clock0 + +(** val preStatus_rect_Type3 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 **) +let rec preStatus_rect_Type3 code_memory h_mk_PreStatus x_22228 = + let { low_internal_ram = low_internal_ram0; high_internal_ram = + high_internal_ram0; external_ram = external_ram0; program_counter = + program_counter0; special_function_registers_8051 = + special_function_registers_8053; special_function_registers_8052 = + special_function_registers_8054; p1_latch = p1_latch0; p3_latch = + p3_latch0; clock = clock0 } = x_22228 + in + h_mk_PreStatus low_internal_ram0 high_internal_ram0 external_ram0 + program_counter0 special_function_registers_8053 + special_function_registers_8054 p1_latch0 p3_latch0 clock0 + +(** val preStatus_rect_Type2 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 **) +let rec preStatus_rect_Type2 code_memory h_mk_PreStatus x_22230 = + let { low_internal_ram = low_internal_ram0; high_internal_ram = + high_internal_ram0; external_ram = external_ram0; program_counter = + program_counter0; special_function_registers_8051 = + special_function_registers_8053; special_function_registers_8052 = + special_function_registers_8054; p1_latch = p1_latch0; p3_latch = + p3_latch0; clock = clock0 } = x_22230 + in + h_mk_PreStatus low_internal_ram0 high_internal_ram0 external_ram0 + program_counter0 special_function_registers_8053 + special_function_registers_8054 p1_latch0 p3_latch0 clock0 + +(** val preStatus_rect_Type1 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 **) +let rec preStatus_rect_Type1 code_memory h_mk_PreStatus x_22232 = + let { low_internal_ram = low_internal_ram0; high_internal_ram = + high_internal_ram0; external_ram = external_ram0; program_counter = + program_counter0; special_function_registers_8051 = + special_function_registers_8053; special_function_registers_8052 = + special_function_registers_8054; p1_latch = p1_latch0; p3_latch = + p3_latch0; clock = clock0 } = x_22232 + in + h_mk_PreStatus low_internal_ram0 high_internal_ram0 external_ram0 + program_counter0 special_function_registers_8053 + special_function_registers_8054 p1_latch0 p3_latch0 clock0 + +(** val preStatus_rect_Type0 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 **) +let rec preStatus_rect_Type0 code_memory h_mk_PreStatus x_22234 = + let { low_internal_ram = low_internal_ram0; high_internal_ram = + high_internal_ram0; external_ram = external_ram0; program_counter = + program_counter0; special_function_registers_8051 = + special_function_registers_8053; special_function_registers_8052 = + special_function_registers_8054; p1_latch = p1_latch0; p3_latch = + p3_latch0; clock = clock0 } = x_22234 + in + h_mk_PreStatus low_internal_ram0 high_internal_ram0 external_ram0 + program_counter0 special_function_registers_8053 + special_function_registers_8054 p1_latch0 p3_latch0 clock0 + +(** val low_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie **) +let rec low_internal_ram code_memory xxx = + xxx.low_internal_ram + +(** val high_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie **) +let rec high_internal_ram code_memory xxx = + xxx.high_internal_ram + +(** val external_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie **) +let rec external_ram code_memory xxx = + xxx.external_ram + +(** val program_counter : 'a1 -> 'a1 preStatus -> BitVector.word **) +let rec program_counter code_memory xxx = + xxx.program_counter + +(** val special_function_registers_8051 : + 'a1 -> 'a1 preStatus -> BitVector.byte Vector.vector **) +let rec special_function_registers_8051 code_memory xxx = + xxx.special_function_registers_8051 + +(** val special_function_registers_8052 : + 'a1 -> 'a1 preStatus -> BitVector.byte Vector.vector **) +let rec special_function_registers_8052 code_memory xxx = + xxx.special_function_registers_8052 + +(** val p1_latch : 'a1 -> 'a1 preStatus -> BitVector.byte **) +let rec p1_latch code_memory xxx = + xxx.p1_latch + +(** val p3_latch : 'a1 -> 'a1 preStatus -> BitVector.byte **) +let rec p3_latch code_memory xxx = + xxx.p3_latch + +(** val clock : 'a1 -> 'a1 preStatus -> time **) +let rec clock code_memory xxx = + xxx.clock + +(** val preStatus_inv_rect_Type4 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 **) +let preStatus_inv_rect_Type4 x2 hterm h1 = + let hcut = preStatus_rect_Type4 x2 h1 hterm in hcut __ + +(** val preStatus_inv_rect_Type3 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 **) +let preStatus_inv_rect_Type3 x2 hterm h1 = + let hcut = preStatus_rect_Type3 x2 h1 hterm in hcut __ + +(** val preStatus_inv_rect_Type2 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 **) +let preStatus_inv_rect_Type2 x2 hterm h1 = + let hcut = preStatus_rect_Type2 x2 h1 hterm in hcut __ + +(** val preStatus_inv_rect_Type1 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 **) +let preStatus_inv_rect_Type1 x2 hterm h1 = + let hcut = preStatus_rect_Type1 x2 h1 hterm in hcut __ + +(** val preStatus_inv_rect_Type0 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 **) +let preStatus_inv_rect_Type0 x2 hterm h1 = + let hcut = preStatus_rect_Type0 x2 h1 hterm in hcut __ + +(** val preStatus_jmdiscr : 'a1 -> 'a1 preStatus -> 'a1 preStatus -> __ **) +let preStatus_jmdiscr a2 x y = + Logic.eq_rect_Type2 x + (let { low_internal_ram = a0; high_internal_ram = a10; external_ram = + a20; program_counter = a3; special_function_registers_8051 = a4; + special_function_registers_8052 = a5; p1_latch = a6; p3_latch = a7; + clock = a8 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __)) y + +type status = BitVector.byte BitVectorTrie.bitVectorTrie preStatus + +type pseudoStatus = ASM.pseudo_assembly_program preStatus + +(** val set_clock : 'a1 -> 'a1 preStatus -> time -> 'a1 preStatus **) +let set_clock code_memory s t = + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = old_external_ram; program_counter = + old_program_counter; special_function_registers_8051 = + old_special_function_registers_8051; special_function_registers_8052 = + old_special_function_registers_8052; p1_latch = old_p1_latch; p3_latch = + old_p3_latch; clock = t } + +(** val set_p1_latch : + 'a1 -> 'a1 preStatus -> BitVector.byte -> 'a1 preStatus **) +let set_p1_latch code_memory s b = + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = old_external_ram; program_counter = + old_program_counter; special_function_registers_8051 = + old_special_function_registers_8051; special_function_registers_8052 = + old_special_function_registers_8052; p1_latch = b; p3_latch = old_p3_latch; + clock = old_clock } + +(** val set_p3_latch : + 'a1 -> 'a1 preStatus -> BitVector.byte -> 'a1 preStatus **) +let set_p3_latch code_memory s b = + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p1_latch = s.p1_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = old_external_ram; program_counter = + old_program_counter; special_function_registers_8051 = + old_special_function_registers_8051; special_function_registers_8052 = + old_special_function_registers_8052; p1_latch = old_p1_latch; p3_latch = b; + clock = old_clock } + +(** val get_8051_sfr : 'a1 -> 'a1 preStatus -> sFR8051 -> BitVector.byte **) +let get_8051_sfr code_memory s i = + let sfr = s.special_function_registers_8051 in + let index = sfr_8051_index i in + Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))))) sfr index + +(** val get_8052_sfr : 'a1 -> 'a1 preStatus -> sFR8052 -> BitVector.byte **) +let get_8052_sfr code_memory s i = + let sfr = s.special_function_registers_8052 in + let index = sfr_8052_index i in + Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) sfr index + +(** val set_8051_sfr : + 'a1 -> 'a1 preStatus -> sFR8051 -> BitVector.byte -> 'a1 preStatus **) +let set_8051_sfr code_memory s i b = + let index = sfr_8051_index i in + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let new_special_function_registers_8051 = + Vector.set_index (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))))) old_special_function_registers_8051 + index b + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = old_external_ram; program_counter = + old_program_counter; special_function_registers_8051 = + new_special_function_registers_8051; special_function_registers_8052 = + old_special_function_registers_8052; p1_latch = old_p1_latch; p3_latch = + old_p3_latch; clock = old_clock } + +(** val set_8052_sfr : + 'a1 -> 'a1 preStatus -> sFR8052 -> BitVector.byte -> 'a1 preStatus **) +let set_8052_sfr code_memory s i b = + let index = sfr_8052_index i in + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let new_special_function_registers_8052 = + Vector.set_index (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + old_special_function_registers_8052 index b + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = old_external_ram; program_counter = + old_program_counter; special_function_registers_8051 = + old_special_function_registers_8051; special_function_registers_8052 = + new_special_function_registers_8052; p1_latch = old_p1_latch; p3_latch = + old_p3_latch; clock = old_clock } + +(** val set_program_counter : + 'a1 -> 'a1 preStatus -> BitVector.word -> 'a1 preStatus **) +let set_program_counter code_memory s w = + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = old_external_ram; program_counter = + w; special_function_registers_8051 = old_special_function_registers_8051; + special_function_registers_8052 = old_special_function_registers_8052; + p1_latch = old_p1_latch; p3_latch = old_p3_latch; clock = old_clock } + +(** val set_code_memory : 'a1 -> 'a1 preStatus -> 'a2 -> 'a2 preStatus **) +let set_code_memory code_memory s r = + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = old_external_ram; program_counter = + old_program_counter; special_function_registers_8051 = + old_special_function_registers_8051; special_function_registers_8052 = + old_special_function_registers_8052; p1_latch = old_p1_latch; p3_latch = + old_p3_latch; clock = old_clock } + +(** val set_low_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie -> 'a1 + preStatus **) +let set_low_internal_ram code_memory s r = + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = r; high_internal_ram = old_high_internal_ram; + external_ram = old_external_ram; program_counter = old_program_counter; + special_function_registers_8051 = old_special_function_registers_8051; + special_function_registers_8052 = old_special_function_registers_8052; + p1_latch = old_p1_latch; p3_latch = old_p3_latch; clock = old_clock } + +(** val update_low_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus **) +let update_low_internal_ram code_memory s addr v = + let old_low_internal_ram = s.low_internal_ram in + let new_low_internal_ram = + BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) addr v old_low_internal_ram + in + set_low_internal_ram code_memory s new_low_internal_ram + +(** val set_high_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie -> 'a1 + preStatus **) +let set_high_internal_ram code_memory s r = + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_external_ram = s.external_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = r; + external_ram = old_external_ram; program_counter = old_program_counter; + special_function_registers_8051 = old_special_function_registers_8051; + special_function_registers_8052 = old_special_function_registers_8052; + p1_latch = old_p1_latch; p3_latch = old_p3_latch; clock = old_clock } + +(** val update_high_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus **) +let update_high_internal_ram code_memory s addr v = + let old_high_internal_ram = s.high_internal_ram in + let new_high_internal_ram = + BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) addr v old_high_internal_ram + in + set_high_internal_ram code_memory s new_high_internal_ram + +(** val set_external_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie -> 'a1 + preStatus **) +let set_external_ram code_memory s r = + let old_low_internal_ram = s.low_internal_ram in + let old_high_internal_ram = s.high_internal_ram in + let old_program_counter = s.program_counter in + let old_special_function_registers_8051 = s.special_function_registers_8051 + in + let old_special_function_registers_8052 = s.special_function_registers_8052 + in + let old_p1_latch = s.p1_latch in + let old_p3_latch = s.p3_latch in + let old_clock = s.clock in + { low_internal_ram = old_low_internal_ram; high_internal_ram = + old_high_internal_ram; external_ram = r; program_counter = + old_program_counter; special_function_registers_8051 = + old_special_function_registers_8051; special_function_registers_8052 = + old_special_function_registers_8052; p1_latch = old_p1_latch; p3_latch = + old_p3_latch; clock = old_clock } + +(** val update_external_ram : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus **) +let update_external_ram code_memory s addr v = + let old_external_ram = s.external_ram in + let new_external_ram = + BitVectorTrie.insert (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr v old_external_ram + in + set_external_ram code_memory s new_external_ram + +(** val get_psw_flags : 'a1 -> 'a1 preStatus -> Nat.nat -> Bool.bool **) +let get_psw_flags code_memory s flag = + let psw = get_8051_sfr code_memory s SFR_PSW in + Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) psw flag + +(** val get_cy_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_cy_flag code_memory s = + get_psw_flags code_memory s Nat.O + +(** val get_ac_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_ac_flag code_memory s = + get_psw_flags code_memory s (Nat.S Nat.O) + +(** val get_fo_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_fo_flag code_memory s = + get_psw_flags code_memory s (Nat.S (Nat.S Nat.O)) + +(** val get_rs1_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_rs1_flag code_memory s = + get_psw_flags code_memory s (Nat.S (Nat.S (Nat.S Nat.O))) + +(** val get_rs0_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_rs0_flag code_memory s = + get_psw_flags code_memory s (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + +(** val get_ov_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_ov_flag code_memory s = + get_psw_flags code_memory s (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + +(** val get_ud_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_ud_flag code_memory s = + get_psw_flags code_memory s (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) + +(** val get_p_flag : 'a1 -> 'a1 preStatus -> Bool.bool **) +let get_p_flag code_memory s = + get_psw_flags code_memory s (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) + +(** val set_flags : + 'a1 -> 'a1 preStatus -> BitVector.bit -> BitVector.bit Types.option -> + BitVector.bit -> 'a1 preStatus **) +let set_flags code_memory s cy ac ov = + let old_cy = get_cy_flag code_memory s in + let old_ac = get_ac_flag code_memory s in + let old_fo = get_fo_flag code_memory s in + let old_rs1 = get_rs1_flag code_memory s in + let old_rs0 = get_rs0_flag code_memory s in + let old_ov = get_ov_flag code_memory s in + let old_ud = get_ud_flag code_memory s in + let old_p = get_p_flag code_memory s in + let new_ac = + match ac with + | Types.None -> old_ac + | Types.Some j -> j + in + set_8051_sfr code_memory s SFR_PSW (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), cy, (Vector.VCons ((Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))), new_ac, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))), old_fo, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), old_rs1, (Vector.VCons ((Nat.S + (Nat.S (Nat.S Nat.O))), old_rs0, (Vector.VCons ((Nat.S (Nat.S Nat.O)), + ov, (Vector.VCons ((Nat.S Nat.O), old_ud, (Vector.VCons (Nat.O, old_p, + Vector.VEmpty)))))))))))))))) + +(** val initialise_status : 'a1 -> 'a1 preStatus **) +let initialise_status code_mem = + let status0 = { low_internal_ram = (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))))))); high_internal_ram = + (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))); external_ram = (BitVectorTrie.Stub (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))))))))))); program_counter = + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))); special_function_registers_8051 = + (Vector.replicate (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))))))))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))); special_function_registers_8052 = + (Vector.replicate (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))); p1_latch = + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))); p3_latch = + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))); clock = Nat.O } + in + set_8051_sfr code_mem status0 SFR_SP + (Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) + +(** val sfr_of_Byte : + BitVector.byte -> (sFR8051, sFR8052) Types.sum Types.option **) +let sfr_of_Byte b = + let address = + Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) b + in + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.None + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inl SFR_P1) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.None + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inl SFR_P3) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inl SFR_SBUF) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inl SFR_TL0) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inl SFR_TL1) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inl SFR_TH0) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inl SFR_TH1) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> Types.Some (Types.Inr SFR_T2CON) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inr SFR_RCAP2L) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inr SFR_RCAP2H) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inr SFR_TL2) + | Bool.False -> + (match Nat.eqb address (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inr SFR_TH2) + | Bool.False -> + (match Nat.eqb address (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inl + SFR_PCON) + | Bool.False -> + (match Nat.eqb address (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inl + SFR_TCON) + | Bool.False -> + (match Nat.eqb address + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inl + SFR_TMOD) + | Bool.False -> + (match Nat.eqb address + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + (Nat.S (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some (Types.Inl + SFR_SCON) + | Bool.False -> + (match Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_IE) + | Bool.False -> + (match Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_IP) + | Bool.False -> + (match + Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_SP) + | Bool.False -> + (match + Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_DPL) + | Bool.False -> + (match + Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_DPH) + | Bool.False -> + (match + Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_PSW) + | Bool.False -> + (match + Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_ACC_A) + | Bool.False -> + (match + Nat.eqb + address + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + (Nat.S + Nat.O)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) with + | Bool.True -> + Types.Some + (Types.Inl + SFR_ACC_B) + | Bool.False -> + Types.None)))))))))))))))))))))))))) + +(** val get_bit_addressable_sfr : + 'a1 -> 'a1 preStatus -> BitVector.byte -> Bool.bool -> BitVector.byte **) +let get_bit_addressable_sfr code_memory s b l = + match sfr_of_Byte b with + | Types.None -> assert false (* absurd case *) + | Types.Some sfr8051_8052 -> + (match sfr8051_8052 with + | Types.Inl sfr -> + (match sfr with + | SFR_SP -> get_8051_sfr code_memory s sfr + | SFR_DPL -> get_8051_sfr code_memory s sfr + | SFR_DPH -> get_8051_sfr code_memory s sfr + | SFR_PCON -> get_8051_sfr code_memory s sfr + | SFR_TCON -> get_8051_sfr code_memory s sfr + | SFR_TMOD -> get_8051_sfr code_memory s sfr + | SFR_TL0 -> get_8051_sfr code_memory s sfr + | SFR_TL1 -> get_8051_sfr code_memory s sfr + | SFR_TH0 -> get_8051_sfr code_memory s sfr + | SFR_TH1 -> get_8051_sfr code_memory s sfr + | SFR_P1 -> + (match l with + | Bool.True -> s.p1_latch + | Bool.False -> get_8051_sfr code_memory s SFR_P1) + | SFR_SCON -> get_8051_sfr code_memory s sfr + | SFR_SBUF -> get_8051_sfr code_memory s sfr + | SFR_IE -> get_8051_sfr code_memory s sfr + | SFR_P3 -> + (match l with + | Bool.True -> s.p3_latch + | Bool.False -> get_8051_sfr code_memory s SFR_P3) + | SFR_IP -> get_8051_sfr code_memory s sfr + | SFR_PSW -> get_8051_sfr code_memory s sfr + | SFR_ACC_A -> get_8051_sfr code_memory s sfr + | SFR_ACC_B -> get_8051_sfr code_memory s sfr) + | Types.Inr sfr -> get_8052_sfr code_memory s sfr) + +(** val set_bit_addressable_sfr : + 'a1 -> 'a1 preStatus -> BitVector.byte -> BitVector.byte -> 'a1 preStatus **) +let set_bit_addressable_sfr code_memory s b v = + match sfr_of_Byte b with + | Types.None -> assert false (* absurd case *) + | Types.Some sfr8051_8052 -> + (match sfr8051_8052 with + | Types.Inl sfr -> + (match sfr with + | SFR_SP -> set_8051_sfr code_memory s sfr v + | SFR_DPL -> set_8051_sfr code_memory s sfr v + | SFR_DPH -> set_8051_sfr code_memory s sfr v + | SFR_PCON -> set_8051_sfr code_memory s sfr v + | SFR_TCON -> set_8051_sfr code_memory s sfr v + | SFR_TMOD -> set_8051_sfr code_memory s sfr v + | SFR_TL0 -> set_8051_sfr code_memory s sfr v + | SFR_TL1 -> set_8051_sfr code_memory s sfr v + | SFR_TH0 -> set_8051_sfr code_memory s sfr v + | SFR_TH1 -> set_8051_sfr code_memory s sfr v + | SFR_P1 -> + let status_1 = set_8051_sfr code_memory s SFR_P1 v in + set_p1_latch code_memory s v + | SFR_SCON -> set_8051_sfr code_memory s sfr v + | SFR_SBUF -> set_8051_sfr code_memory s sfr v + | SFR_IE -> set_8051_sfr code_memory s sfr v + | SFR_P3 -> + let status_1 = set_8051_sfr code_memory s SFR_P3 v in + set_p3_latch code_memory s v + | SFR_IP -> set_8051_sfr code_memory s sfr v + | SFR_PSW -> set_8051_sfr code_memory s sfr v + | SFR_ACC_A -> set_8051_sfr code_memory s sfr v + | SFR_ACC_B -> set_8051_sfr code_memory s sfr v) + | Types.Inr sfr -> set_8052_sfr code_memory s sfr v) + +(** val bit_address_of_register : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.bitVector **) +let bit_address_of_register code_memory s r = + let b = Vector.get_index_v (Nat.S (Nat.S (Nat.S Nat.O))) r Nat.O in + let c = Vector.get_index_v (Nat.S (Nat.S (Nat.S Nat.O))) r (Nat.S Nat.O) in + let d = + Vector.get_index_v (Nat.S (Nat.S (Nat.S Nat.O))) r (Nat.S (Nat.S Nat.O)) + in + let r1 = get_rs1_flag code_memory s in + let r0 = get_rs0_flag code_memory s in + let offset = + match Bool.andb (Bool.notb r1) (Bool.notb r0) with + | Bool.True -> Nat.O + | Bool.False -> + (match Bool.andb (Bool.notb r1) r0 with + | Bool.True -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))) + | Bool.False -> + (match Bool.andb r1 r0 with + | Bool.True -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))))))))) + | Bool.False -> + Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) + in + Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) + (Nat.plus offset + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) + (Vector.VCons ((Nat.S (Nat.S (Nat.S Nat.O))), Bool.False, + (Vector.VCons ((Nat.S (Nat.S Nat.O)), b, (Vector.VCons ((Nat.S + Nat.O), c, (Vector.VCons (Nat.O, d, Vector.VEmpty)))))))))) + +(** val get_register : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte **) +let get_register code_memory s r = + let address = bit_address_of_register code_memory s r in + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) address s.low_internal_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) + +(** val set_register : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus **) +let set_register code_memory s r v = + let address = bit_address_of_register code_memory s r in + update_low_internal_ram code_memory s address v + +(** val read_from_external_ram : + 'a1 -> 'a1 preStatus -> BitVector.word -> BitVector.byte **) +let read_from_external_ram code_memory s addr = + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) addr s.external_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) + +(** val read_from_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte -> BitVector.byte **) +let read_from_internal_ram code_memory s addr = + let { Types.fst = bit_one; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) addr + in + let memory = + match Vector.head' Nat.O bit_one with + | Bool.True -> s.high_internal_ram + | Bool.False -> s.low_internal_ram + in + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))) seven_bits memory + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))) + +(** val read_at_stack_pointer : 'a1 -> 'a1 preStatus -> BitVector.byte **) +let read_at_stack_pointer code_memory s = + read_from_internal_ram code_memory s (get_8051_sfr code_memory s SFR_SP) + +(** val write_at_stack_pointer : + 'a1 -> 'a1 preStatus -> BitVector.byte -> 'a1 preStatus **) +let write_at_stack_pointer code_memory s v = + let { Types.fst = bit_one; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) (get_8051_sfr code_memory s SFR_SP) + in + (match Vector.head' Nat.O bit_one with + | Bool.True -> update_high_internal_ram code_memory s seven_bits v + | Bool.False -> update_low_internal_ram code_memory s seven_bits v) + +(** val set_arg_16' : + 'a1 -> 'a1 preStatus -> BitVector.word -> ASM.subaddressing_mode -> 'a1 + preStatus Types.sig0 **) +let set_arg_16' code_memory s v a = + (match ASM.subaddressing_modeel Nat.O (Vector.VCons (Nat.O, ASM.Dptr, + Vector.VEmpty)) a with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> + (fun _ -> + (let { Types.fst = bu; Types.snd = bl } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) v + in + (fun _ -> + let status0 = set_8051_sfr code_memory s SFR_DPH bu in + let status1 = set_8051_sfr code_memory status0 SFR_DPL bl in status1)) + __) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + +(** val set_arg_16 : + 'a1 -> 'a1 preStatus -> BitVector.word -> ASM.subaddressing_mode -> 'a1 + preStatus **) +let set_arg_16 code_memory s h h1 = + Types.pi1 (set_arg_16' code_memory s h h1) + +(** val get_arg_16 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> BitVector.word **) +let get_arg_16 cm s a = + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + ASM.Data16, (Vector.VCons (Nat.O, ASM.Acc_dptr, Vector.VEmpty)))) + a with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 d -> (fun _ -> d) + | ASM.ACC_DPTR -> + (fun _ -> + let dptr = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (get_8051_sfr cm s SFR_DPH) + (get_8051_sfr cm s SFR_DPL) + in + let big_acc = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) (get_8051_sfr cm s SFR_ACC_A) + in + Arithmetic.add + (Nat.plus (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) big_acc dptr) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + +(** val get_arg_8 : + 'a1 -> 'a1 preStatus -> Bool.bool -> ASM.subaddressing_mode -> + BitVector.byte **) +let get_arg_8 cm s l a = + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))))))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))))), + ASM.Direct, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O)))))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), + ASM.Registr, (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Acc_a, (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))), ASM.Acc_b, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), ASM.Data, (Vector.VCons ((Nat.S (Nat.S + (Nat.S Nat.O))), ASM.Acc_dptr, (Vector.VCons ((Nat.S (Nat.S + Nat.O)), ASM.Acc_pc, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))))))))) a with + | ASM.DIRECT d -> + (fun _ -> + let { Types.fst = hd; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) d + in + (match Vector.head' Nat.O hd with + | Bool.True -> + get_bit_addressable_sfr cm s (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, seven_bits)) + l + | Bool.False -> + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) seven_bits s.low_internal_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))) + | ASM.INDIRECT i -> + (fun _ -> + let { Types.fst = hd; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) + (get_register cm s (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.False, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, i, Vector.VEmpty))))))) + in + (match Vector.head' Nat.O hd with + | Bool.True -> + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) seven_bits s.high_internal_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))) + | Bool.False -> + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) seven_bits s.low_internal_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))))))) + | ASM.EXT_INDIRECT e -> + (fun _ -> + let address = + get_register cm s (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, e, + Vector.VEmpty)))))) + in + let padded_address = + BitVector.pad (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) address + in + read_from_external_ram cm s padded_address) + | ASM.REGISTER r -> (fun _ -> get_register cm s r) + | ASM.ACC_A -> (fun _ -> get_8051_sfr cm s SFR_ACC_A) + | ASM.ACC_B -> (fun _ -> get_8051_sfr cm s SFR_ACC_B) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA d -> (fun _ -> d) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> + (fun _ -> + let dptr = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (get_8051_sfr cm s SFR_DPH) + (get_8051_sfr cm s SFR_DPL) + in + let padded_acc = + BitVector.pad (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (get_8051_sfr cm s SFR_ACC_A) + in + let { Types.fst = carry; Types.snd = address } = + Arithmetic.half_add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) dptr padded_acc + in + read_from_external_ram cm s address) + | ASM.ACC_PC -> + (fun _ -> + let padded_acc = + BitVector.pad (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (get_8051_sfr cm s SFR_ACC_A) + in + let { Types.fst = carry; Types.snd = address } = + Arithmetic.half_add (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))))))))))))) s.program_counter padded_acc + in + read_from_external_ram cm s address) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> + let address = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (get_8051_sfr cm s SFR_DPH) + (get_8051_sfr cm s SFR_DPL) + in + read_from_external_ram cm s address) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + +(** val set_arg_8 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> BitVector.byte -> 'a1 + preStatus **) +let set_arg_8 cm s a v = + (match ASM.subaddressing_modeel (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O)))))) (Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))), ASM.Direct, (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S Nat.O))))), ASM.Indirect, (Vector.VCons + ((Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))), ASM.Registr, (Vector.VCons + ((Nat.S (Nat.S (Nat.S Nat.O))), ASM.Acc_a, (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Acc_b, (Vector.VCons ((Nat.S Nat.O), + ASM.Ext_indirect, (Vector.VCons (Nat.O, ASM.Ext_indirect_dptr, + Vector.VEmpty)))))))))))))) a with + | ASM.DIRECT d -> + (fun _ -> + let { Types.fst = bit_one; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) d + in + (match Vector.head' Nat.O bit_one with + | Bool.True -> + set_bit_addressable_sfr cm s (Vector.VCons ((Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))))), Bool.True, seven_bits)) + v + | Bool.False -> update_low_internal_ram cm s seven_bits v)) + | ASM.INDIRECT i -> + (fun _ -> + let register = + get_register cm s (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, i, + Vector.VEmpty)))))) + in + let { Types.fst = bit_one; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) register + in + (match Vector.head' Nat.O bit_one with + | Bool.True -> update_high_internal_ram cm s seven_bits v + | Bool.False -> update_low_internal_ram cm s seven_bits v)) + | ASM.EXT_INDIRECT e -> + (fun _ -> + let address = + get_register cm s (Vector.VCons ((Nat.S (Nat.S Nat.O)), Bool.False, + (Vector.VCons ((Nat.S Nat.O), Bool.False, (Vector.VCons (Nat.O, e, + Vector.VEmpty)))))) + in + let padded_address = + BitVector.pad (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) address + in + update_external_ram cm s padded_address v) + | ASM.REGISTER r -> (fun _ -> set_register cm s r v) + | ASM.ACC_A -> (fun _ -> set_8051_sfr cm s SFR_ACC_A v) + | ASM.ACC_B -> (fun _ -> set_8051_sfr cm s SFR_ACC_B v) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> + (fun _ -> + let address = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) (get_8051_sfr cm s SFR_DPH) + (get_8051_sfr cm s SFR_DPL) + in + update_external_ram cm s address v) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> assert false (* absurd case *)) + | ASM.BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + +(** val get_arg_1 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> Bool.bool -> Bool.bool **) +let get_arg_1 cm s a l = + (match ASM.subaddressing_modeel (Nat.S (Nat.S Nat.O)) (Vector.VCons ((Nat.S + (Nat.S Nat.O)), ASM.Bit_addr, (Vector.VCons ((Nat.S Nat.O), + ASM.N_bit_addr, (Vector.VCons (Nat.O, ASM.Carry, + Vector.VEmpty)))))) a with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> (fun _ -> get_cy_flag cm s) + | ASM.BIT_ADDR b -> + (fun _ -> + let { Types.fst = bit_1; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) b + in + let { Types.fst = four_bits; Types.snd = three_bits } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S Nat.O))) seven_bits + in + (match Vector.head' Nat.O bit_1 with + | Bool.True -> + let trans = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.True, four_bits)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) + in + let sfr = get_bit_addressable_sfr cm s trans l in + Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) sfr + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S Nat.O))) + three_bits) + | Bool.False -> + let address' = + Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))) four_bits + in + let t = + BitVectorTrie.lookup + (Nat.plus (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))) address' s.low_internal_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) + in + Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) t + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S Nat.O))) + three_bits))) + | ASM.N_BIT_ADDR n -> + (fun _ -> + let { Types.fst = bit_1; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) n + in + let { Types.fst = four_bits; Types.snd = three_bits } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S Nat.O))) seven_bits + in + (match Vector.head' Nat.O bit_1 with + | Bool.True -> + let trans = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.True, four_bits)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) + in + let sfr = get_bit_addressable_sfr cm s trans l in + Bool.notb + (Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) sfr + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S Nat.O))) + three_bits)) + | Bool.False -> + let address' = + Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))) four_bits + in + let t = + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) address' s.low_internal_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) + in + Bool.notb + (Vector.get_index_v (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))))))) t + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S Nat.O))) + three_bits)))) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + +(** val set_arg_1 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> BitVector.bit -> 'a1 + preStatus **) +let set_arg_1 cm s a v = + (match ASM.subaddressing_modeel (Nat.S Nat.O) (Vector.VCons ((Nat.S Nat.O), + ASM.Bit_addr, (Vector.VCons (Nat.O, ASM.Carry, Vector.VEmpty)))) a with + | ASM.DIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT x -> (fun _ -> assert false (* absurd case *)) + | ASM.REGISTER x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_A -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_B -> (fun _ -> assert false (* absurd case *)) + | ASM.DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA x -> (fun _ -> assert false (* absurd case *)) + | ASM.DATA16 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.ACC_PC -> (fun _ -> assert false (* absurd case *)) + | ASM.EXT_INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.INDIRECT_DPTR -> (fun _ -> assert false (* absurd case *)) + | ASM.CARRY -> + (fun _ -> + let { Types.fst = ignore; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) (get_8051_sfr cm s SFR_PSW) + in + let new_psw = Vector.VCons ((Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))), v, seven_bits) + in + set_8051_sfr cm s SFR_PSW new_psw) + | ASM.BIT_ADDR b -> + (fun _ -> + let { Types.fst = bit_1; Types.snd = seven_bits } = + Vector.vsplit (Nat.S Nat.O) (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))) b + in + let { Types.fst = four_bits; Types.snd = three_bits } = + Vector.vsplit (Nat.S (Nat.S (Nat.S (Nat.S Nat.O)))) (Nat.S (Nat.S + (Nat.S Nat.O))) seven_bits + in + (match Vector.head' Nat.O bit_1 with + | Bool.True -> + let trans = + Vector.append (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S Nat.O))))) + (Nat.S (Nat.S (Nat.S Nat.O))) (Vector.VCons ((Nat.S (Nat.S + (Nat.S (Nat.S Nat.O)))), Bool.True, four_bits)) (Vector.VCons + ((Nat.S (Nat.S Nat.O)), Bool.False, (Vector.VCons ((Nat.S + Nat.O), Bool.False, (Vector.VCons (Nat.O, Bool.False, + Vector.VEmpty)))))) + in + let sfr = get_bit_addressable_sfr cm s trans Bool.True in + let new_sfr = + Vector.set_index (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) sfr + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S Nat.O))) + three_bits) v + in + set_bit_addressable_sfr cm s new_sfr trans + | Bool.False -> + let address' = + Vector.append (Nat.S (Nat.S (Nat.S Nat.O))) (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))) (Vector.VCons ((Nat.S (Nat.S Nat.O)), + Bool.True, (Vector.VCons ((Nat.S Nat.O), Bool.False, + (Vector.VCons (Nat.O, Bool.False, Vector.VEmpty)))))) four_bits + in + let t = + BitVectorTrie.lookup (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O))))))) address' s.low_internal_ram + (BitVector.zero (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S Nat.O))))))))) + in + let n_bit = + Vector.set_index (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))) t + (Arithmetic.nat_of_bitvector (Nat.S (Nat.S (Nat.S Nat.O))) + three_bits) v + in + update_low_internal_ram cm s address' n_bit)) + | ASM.N_BIT_ADDR x -> (fun _ -> assert false (* absurd case *)) + | ASM.RELATIVE x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR11 x -> (fun _ -> assert false (* absurd case *)) + | ASM.ADDR16 x -> (fun _ -> assert false (* absurd case *))) __ + +(** val construct_datalabels : + (ASM.identifier, BitVector.word) Types.prod List.list -> BitVector.word + Identifiers.identifier_map **) +let construct_datalabels the_preamble = + (Util.foldl (fun t preamble -> + let { Types.fst = datalabels; Types.snd = addr } = t in + let { Types.fst = name; Types.snd = size } = preamble in + let { Types.fst = addr0; Types.snd = carry } = + Arithmetic.sub_16_with_carry addr size Bool.False + in + { Types.fst = + (Identifiers.add PreIdentifiers.ASMTag datalabels name addr0); + Types.snd = addr0 }) { Types.fst = + (Identifiers.empty_map PreIdentifiers.ASMTag); Types.snd = + (BitVector.maximum (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + Nat.O))))))))))))))))) } the_preamble).Types.fst + diff --git a/extracted/status.mli b/extracted/status.mli new file mode 100644 index 0000000..8b8ded5 --- /dev/null +++ b/extracted/status.mli @@ -0,0 +1,561 @@ +open Preamble + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +type time = Nat.nat + +type serialBufferType = +| Eight of BitVector.byte +| Nine of BitVector.bit * BitVector.byte + +val serialBufferType_rect_Type4 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 + +val serialBufferType_rect_Type5 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 + +val serialBufferType_rect_Type3 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 + +val serialBufferType_rect_Type2 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 + +val serialBufferType_rect_Type1 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 + +val serialBufferType_rect_Type0 : + (BitVector.byte -> 'a1) -> (BitVector.bit -> BitVector.byte -> 'a1) -> + serialBufferType -> 'a1 + +val serialBufferType_inv_rect_Type4 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 + +val serialBufferType_inv_rect_Type3 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 + +val serialBufferType_inv_rect_Type2 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 + +val serialBufferType_inv_rect_Type1 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 + +val serialBufferType_inv_rect_Type0 : + serialBufferType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.bit -> + BitVector.byte -> __ -> 'a1) -> 'a1 + +val serialBufferType_discr : serialBufferType -> serialBufferType -> __ + +val serialBufferType_jmdiscr : serialBufferType -> serialBufferType -> __ + +type lineType = +| P1 of BitVector.byte +| P3 of BitVector.byte +| SerialBuffer of serialBufferType + +val lineType_rect_Type4 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType -> + 'a1) -> lineType -> 'a1 + +val lineType_rect_Type5 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType -> + 'a1) -> lineType -> 'a1 + +val lineType_rect_Type3 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType -> + 'a1) -> lineType -> 'a1 + +val lineType_rect_Type2 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType -> + 'a1) -> lineType -> 'a1 + +val lineType_rect_Type1 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType -> + 'a1) -> lineType -> 'a1 + +val lineType_rect_Type0 : + (BitVector.byte -> 'a1) -> (BitVector.byte -> 'a1) -> (serialBufferType -> + 'a1) -> lineType -> 'a1 + +val lineType_inv_rect_Type4 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) + -> (serialBufferType -> __ -> 'a1) -> 'a1 + +val lineType_inv_rect_Type3 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) + -> (serialBufferType -> __ -> 'a1) -> 'a1 + +val lineType_inv_rect_Type2 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) + -> (serialBufferType -> __ -> 'a1) -> 'a1 + +val lineType_inv_rect_Type1 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) + -> (serialBufferType -> __ -> 'a1) -> 'a1 + +val lineType_inv_rect_Type0 : + lineType -> (BitVector.byte -> __ -> 'a1) -> (BitVector.byte -> __ -> 'a1) + -> (serialBufferType -> __ -> 'a1) -> 'a1 + +val lineType_discr : lineType -> lineType -> __ + +val lineType_jmdiscr : lineType -> lineType -> __ + +type sFR8051 = +| SFR_SP +| SFR_DPL +| SFR_DPH +| SFR_PCON +| SFR_TCON +| SFR_TMOD +| SFR_TL0 +| SFR_TL1 +| SFR_TH0 +| SFR_TH1 +| SFR_P1 +| SFR_SCON +| SFR_SBUF +| SFR_IE +| SFR_P3 +| SFR_IP +| SFR_PSW +| SFR_ACC_A +| SFR_ACC_B + +val sFR8051_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 + +val sFR8051_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 + +val sFR8051_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 + +val sFR8051_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 + +val sFR8051_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 + +val sFR8051_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 + -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8051 -> 'a1 + +val sFR8051_inv_rect_Type4 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val sFR8051_inv_rect_Type3 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val sFR8051_inv_rect_Type2 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val sFR8051_inv_rect_Type1 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val sFR8051_inv_rect_Type0 : + sFR8051 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val sFR8051_discr : sFR8051 -> sFR8051 -> __ + +val sFR8051_jmdiscr : sFR8051 -> sFR8051 -> __ + +val sfr_8051_index : sFR8051 -> Nat.nat + +type sFR8052 = +| SFR_T2CON +| SFR_RCAP2L +| SFR_RCAP2H +| SFR_TL2 +| SFR_TH2 + +val sFR8052_rect_Type4 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 + +val sFR8052_rect_Type5 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 + +val sFR8052_rect_Type3 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 + +val sFR8052_rect_Type2 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 + +val sFR8052_rect_Type1 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 + +val sFR8052_rect_Type0 : 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> sFR8052 -> 'a1 + +val sFR8052_inv_rect_Type4 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 + +val sFR8052_inv_rect_Type3 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 + +val sFR8052_inv_rect_Type2 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 + +val sFR8052_inv_rect_Type1 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 + +val sFR8052_inv_rect_Type0 : + sFR8052 -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 + +val sFR8052_discr : sFR8052 -> sFR8052 -> __ + +val sFR8052_jmdiscr : sFR8052 -> sFR8052 -> __ + +val sfr_8052_index : sFR8052 -> Nat.nat + +type 'm preStatus = { low_internal_ram : BitVector.byte + BitVectorTrie.bitVectorTrie; + high_internal_ram : BitVector.byte + BitVectorTrie.bitVectorTrie; + external_ram : BitVector.byte + BitVectorTrie.bitVectorTrie; + program_counter : BitVector.word; + special_function_registers_8051 : BitVector.byte + Vector.vector; + special_function_registers_8052 : BitVector.byte + Vector.vector; + p1_latch : BitVector.byte; p3_latch : BitVector.byte; + clock : time } + +val preStatus_rect_Type4 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 + +val preStatus_rect_Type5 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 + +val preStatus_rect_Type3 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 + +val preStatus_rect_Type2 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 + +val preStatus_rect_Type1 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 + +val preStatus_rect_Type0 : + 'a1 -> (BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.byte BitVectorTrie.bitVectorTrie + -> BitVector.word -> BitVector.byte Vector.vector -> BitVector.byte + Vector.vector -> BitVector.byte -> BitVector.byte -> time -> 'a2) -> 'a1 + preStatus -> 'a2 + +val low_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie + +val high_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie + +val external_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie + +val program_counter : 'a1 -> 'a1 preStatus -> BitVector.word + +val special_function_registers_8051 : + 'a1 -> 'a1 preStatus -> BitVector.byte Vector.vector + +val special_function_registers_8052 : + 'a1 -> 'a1 preStatus -> BitVector.byte Vector.vector + +val p1_latch : 'a1 -> 'a1 preStatus -> BitVector.byte + +val p3_latch : 'a1 -> 'a1 preStatus -> BitVector.byte + +val clock : 'a1 -> 'a1 preStatus -> time + +val preStatus_inv_rect_Type4 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 + +val preStatus_inv_rect_Type3 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 + +val preStatus_inv_rect_Type2 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 + +val preStatus_inv_rect_Type1 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 + +val preStatus_inv_rect_Type0 : + 'a1 -> 'a1 preStatus -> (BitVector.byte BitVectorTrie.bitVectorTrie -> + BitVector.byte BitVectorTrie.bitVectorTrie -> BitVector.byte + BitVectorTrie.bitVectorTrie -> BitVector.word -> BitVector.byte + Vector.vector -> BitVector.byte Vector.vector -> BitVector.byte -> + BitVector.byte -> time -> __ -> 'a2) -> 'a2 + +val preStatus_jmdiscr : 'a1 -> 'a1 preStatus -> 'a1 preStatus -> __ + +type status = BitVector.byte BitVectorTrie.bitVectorTrie preStatus + +type pseudoStatus = ASM.pseudo_assembly_program preStatus + +val set_clock : 'a1 -> 'a1 preStatus -> time -> 'a1 preStatus + +val set_p1_latch : 'a1 -> 'a1 preStatus -> BitVector.byte -> 'a1 preStatus + +val set_p3_latch : 'a1 -> 'a1 preStatus -> BitVector.byte -> 'a1 preStatus + +val get_8051_sfr : 'a1 -> 'a1 preStatus -> sFR8051 -> BitVector.byte + +val get_8052_sfr : 'a1 -> 'a1 preStatus -> sFR8052 -> BitVector.byte + +val set_8051_sfr : + 'a1 -> 'a1 preStatus -> sFR8051 -> BitVector.byte -> 'a1 preStatus + +val set_8052_sfr : + 'a1 -> 'a1 preStatus -> sFR8052 -> BitVector.byte -> 'a1 preStatus + +val set_program_counter : + 'a1 -> 'a1 preStatus -> BitVector.word -> 'a1 preStatus + +val set_code_memory : 'a1 -> 'a1 preStatus -> 'a2 -> 'a2 preStatus + +val set_low_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie -> 'a1 + preStatus + +val update_low_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus + +val set_high_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie -> 'a1 + preStatus + +val update_high_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus + +val set_external_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte BitVectorTrie.bitVectorTrie -> 'a1 + preStatus + +val update_external_ram : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus + +val get_psw_flags : 'a1 -> 'a1 preStatus -> Nat.nat -> Bool.bool + +val get_cy_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val get_ac_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val get_fo_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val get_rs1_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val get_rs0_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val get_ov_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val get_ud_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val get_p_flag : 'a1 -> 'a1 preStatus -> Bool.bool + +val set_flags : + 'a1 -> 'a1 preStatus -> BitVector.bit -> BitVector.bit Types.option -> + BitVector.bit -> 'a1 preStatus + +val initialise_status : 'a1 -> 'a1 preStatus + +val sfr_of_Byte : BitVector.byte -> (sFR8051, sFR8052) Types.sum Types.option + +val get_bit_addressable_sfr : + 'a1 -> 'a1 preStatus -> BitVector.byte -> Bool.bool -> BitVector.byte + +val set_bit_addressable_sfr : + 'a1 -> 'a1 preStatus -> BitVector.byte -> BitVector.byte -> 'a1 preStatus + +val bit_address_of_register : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.bitVector + +val get_register : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte + +val set_register : + 'a1 -> 'a1 preStatus -> BitVector.bitVector -> BitVector.byte -> 'a1 + preStatus + +val read_from_external_ram : + 'a1 -> 'a1 preStatus -> BitVector.word -> BitVector.byte + +val read_from_internal_ram : + 'a1 -> 'a1 preStatus -> BitVector.byte -> BitVector.byte + +val read_at_stack_pointer : 'a1 -> 'a1 preStatus -> BitVector.byte + +val write_at_stack_pointer : + 'a1 -> 'a1 preStatus -> BitVector.byte -> 'a1 preStatus + +val set_arg_16' : + 'a1 -> 'a1 preStatus -> BitVector.word -> ASM.subaddressing_mode -> 'a1 + preStatus Types.sig0 + +val set_arg_16 : + 'a1 -> 'a1 preStatus -> BitVector.word -> ASM.subaddressing_mode -> 'a1 + preStatus + +val get_arg_16 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> BitVector.word + +val get_arg_8 : + 'a1 -> 'a1 preStatus -> Bool.bool -> ASM.subaddressing_mode -> + BitVector.byte + +val set_arg_8 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> BitVector.byte -> 'a1 + preStatus + +val get_arg_1 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> Bool.bool -> Bool.bool + +val set_arg_1 : + 'a1 -> 'a1 preStatus -> ASM.subaddressing_mode -> BitVector.bit -> 'a1 + preStatus + +val construct_datalabels : + (ASM.identifier, BitVector.word) Types.prod List.list -> BitVector.word + Identifiers.identifier_map + diff --git a/extracted/statusProofs.ml b/extracted/statusProofs.ml new file mode 100644 index 0000000..5523b94 --- /dev/null +++ b/extracted/statusProofs.ml @@ -0,0 +1,82 @@ +open Preamble + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + diff --git a/extracted/statusProofs.mli b/extracted/statusProofs.mli new file mode 100644 index 0000000..5523b94 --- /dev/null +++ b/extracted/statusProofs.mli @@ -0,0 +1,82 @@ +open Preamble + +open BitVectorTrie + +open String + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open LabelledObjects + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Util + +open List + +open Lists + +open Bool + +open Relations + +open Nat + +open Positive + +open Identifiers + +open CostLabel + +open ASM + +open Types + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Jmeq + +open Russell + +open Status + diff --git a/extracted/string.ml b/extracted/string.ml new file mode 100644 index 0000000..5ea5d2d --- /dev/null +++ b/extracted/string.ml @@ -0,0 +1,33 @@ +open Preamble + +open Core_notation + +open Pts + +type string = +| EmptyString + +(** val string_rect_Type4 : 'a1 -> string -> 'a1 **) +let rec string_rect_Type4 h_EmptyString = function +| EmptyString -> h_EmptyString + +(** val string_rect_Type5 : 'a1 -> string -> 'a1 **) +let rec string_rect_Type5 h_EmptyString = function +| EmptyString -> h_EmptyString + +(** val string_rect_Type3 : 'a1 -> string -> 'a1 **) +let rec string_rect_Type3 h_EmptyString = function +| EmptyString -> h_EmptyString + +(** val string_rect_Type2 : 'a1 -> string -> 'a1 **) +let rec string_rect_Type2 h_EmptyString = function +| EmptyString -> h_EmptyString + +(** val string_rect_Type1 : 'a1 -> string -> 'a1 **) +let rec string_rect_Type1 h_EmptyString = function +| EmptyString -> h_EmptyString + +(** val string_rect_Type0 : 'a1 -> string -> 'a1 **) +let rec string_rect_Type0 h_EmptyString = function +| EmptyString -> h_EmptyString + diff --git a/extracted/string.mli b/extracted/string.mli new file mode 100644 index 0000000..618f1f3 --- /dev/null +++ b/extracted/string.mli @@ -0,0 +1,21 @@ +open Preamble + +open Core_notation + +open Pts + +type string = +| EmptyString + +val string_rect_Type4 : 'a1 -> string -> 'a1 + +val string_rect_Type5 : 'a1 -> string -> 'a1 + +val string_rect_Type3 : 'a1 -> string -> 'a1 + +val string_rect_Type2 : 'a1 -> string -> 'a1 + +val string_rect_Type1 : 'a1 -> string -> 'a1 + +val string_rect_Type0 : 'a1 -> string -> 'a1 + diff --git a/extracted/structuredTraces.ml b/extracted/structuredTraces.ml new file mode 100644 index 0000000..f3afa8a --- /dev/null +++ b/extracted/structuredTraces.ml @@ -0,0 +1,1893 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Bool + +open Jmeq + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Russell + +open Util + +open List + +open Lists + +open Nat + +open Positive + +open Types + +open Identifiers + +open CostLabel + +open Sets + +open Listb + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Hide + +type status_class = +| Cl_return +| Cl_jump +| Cl_call +| Cl_tailcall +| Cl_other + +(** val status_class_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 **) +let rec status_class_rect_Type4 h_cl_return h_cl_jump h_cl_call h_cl_tailcall h_cl_other = function +| Cl_return -> h_cl_return +| Cl_jump -> h_cl_jump +| Cl_call -> h_cl_call +| Cl_tailcall -> h_cl_tailcall +| Cl_other -> h_cl_other + +(** val status_class_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 **) +let rec status_class_rect_Type5 h_cl_return h_cl_jump h_cl_call h_cl_tailcall h_cl_other = function +| Cl_return -> h_cl_return +| Cl_jump -> h_cl_jump +| Cl_call -> h_cl_call +| Cl_tailcall -> h_cl_tailcall +| Cl_other -> h_cl_other + +(** val status_class_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 **) +let rec status_class_rect_Type3 h_cl_return h_cl_jump h_cl_call h_cl_tailcall h_cl_other = function +| Cl_return -> h_cl_return +| Cl_jump -> h_cl_jump +| Cl_call -> h_cl_call +| Cl_tailcall -> h_cl_tailcall +| Cl_other -> h_cl_other + +(** val status_class_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 **) +let rec status_class_rect_Type2 h_cl_return h_cl_jump h_cl_call h_cl_tailcall h_cl_other = function +| Cl_return -> h_cl_return +| Cl_jump -> h_cl_jump +| Cl_call -> h_cl_call +| Cl_tailcall -> h_cl_tailcall +| Cl_other -> h_cl_other + +(** val status_class_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 **) +let rec status_class_rect_Type1 h_cl_return h_cl_jump h_cl_call h_cl_tailcall h_cl_other = function +| Cl_return -> h_cl_return +| Cl_jump -> h_cl_jump +| Cl_call -> h_cl_call +| Cl_tailcall -> h_cl_tailcall +| Cl_other -> h_cl_other + +(** val status_class_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 **) +let rec status_class_rect_Type0 h_cl_return h_cl_jump h_cl_call h_cl_tailcall h_cl_other = function +| Cl_return -> h_cl_return +| Cl_jump -> h_cl_jump +| Cl_call -> h_cl_call +| Cl_tailcall -> h_cl_tailcall +| Cl_other -> h_cl_other + +(** val status_class_inv_rect_Type4 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> 'a1 **) +let status_class_inv_rect_Type4 hterm h1 h2 h3 h4 h5 = + let hcut = status_class_rect_Type4 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val status_class_inv_rect_Type3 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> 'a1 **) +let status_class_inv_rect_Type3 hterm h1 h2 h3 h4 h5 = + let hcut = status_class_rect_Type3 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val status_class_inv_rect_Type2 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> 'a1 **) +let status_class_inv_rect_Type2 hterm h1 h2 h3 h4 h5 = + let hcut = status_class_rect_Type2 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val status_class_inv_rect_Type1 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> 'a1 **) +let status_class_inv_rect_Type1 hterm h1 h2 h3 h4 h5 = + let hcut = status_class_rect_Type1 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val status_class_inv_rect_Type0 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> (__ -> 'a1) -> 'a1 **) +let status_class_inv_rect_Type0 hterm h1 h2 h3 h4 h5 = + let hcut = status_class_rect_Type0 h1 h2 h3 h4 h5 hterm in hcut __ + +(** val status_class_discr : status_class -> status_class -> __ **) +let status_class_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Cl_return -> Obj.magic (fun _ dH -> dH) + | Cl_jump -> Obj.magic (fun _ dH -> dH) + | Cl_call -> Obj.magic (fun _ dH -> dH) + | Cl_tailcall -> Obj.magic (fun _ dH -> dH) + | Cl_other -> Obj.magic (fun _ dH -> dH)) y + +(** val status_class_jmdiscr : status_class -> status_class -> __ **) +let status_class_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Cl_return -> Obj.magic (fun _ dH -> dH) + | Cl_jump -> Obj.magic (fun _ dH -> dH) + | Cl_call -> Obj.magic (fun _ dH -> dH) + | Cl_tailcall -> Obj.magic (fun _ dH -> dH) + | Cl_other -> Obj.magic (fun _ dH -> dH)) y + +type abstract_status = { as_pc : Deqsets.deqSet; as_pc_of : (__ -> __); + as_classify : (__ -> status_class); + as_label_of_pc : (__ -> CostLabel.costlabel + Types.option); + as_result : (__ -> Integers.int Types.option); + as_call_ident : (__ Types.sig0 -> AST.ident); + as_tailcall_ident : (__ Types.sig0 -> AST.ident) } + +(** val abstract_status_rect_Type4 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ + -> CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 **) +let rec abstract_status_rect_Type4 h_mk_abstract_status x_22380 = + let { as_pc = as_pc0; as_pc_of = as_pc_of0; as_classify = as_classify0; + as_label_of_pc = as_label_of_pc0; as_result = as_result0; as_call_ident = + as_call_ident0; as_tailcall_ident = as_tailcall_ident0 } = x_22380 + in + h_mk_abstract_status __ __ as_pc0 as_pc_of0 as_classify0 as_label_of_pc0 __ + as_result0 as_call_ident0 as_tailcall_ident0 + +(** val abstract_status_rect_Type5 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ + -> CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 **) +let rec abstract_status_rect_Type5 h_mk_abstract_status x_22382 = + let { as_pc = as_pc0; as_pc_of = as_pc_of0; as_classify = as_classify0; + as_label_of_pc = as_label_of_pc0; as_result = as_result0; as_call_ident = + as_call_ident0; as_tailcall_ident = as_tailcall_ident0 } = x_22382 + in + h_mk_abstract_status __ __ as_pc0 as_pc_of0 as_classify0 as_label_of_pc0 __ + as_result0 as_call_ident0 as_tailcall_ident0 + +(** val abstract_status_rect_Type3 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ + -> CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 **) +let rec abstract_status_rect_Type3 h_mk_abstract_status x_22384 = + let { as_pc = as_pc0; as_pc_of = as_pc_of0; as_classify = as_classify0; + as_label_of_pc = as_label_of_pc0; as_result = as_result0; as_call_ident = + as_call_ident0; as_tailcall_ident = as_tailcall_ident0 } = x_22384 + in + h_mk_abstract_status __ __ as_pc0 as_pc_of0 as_classify0 as_label_of_pc0 __ + as_result0 as_call_ident0 as_tailcall_ident0 + +(** val abstract_status_rect_Type2 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ + -> CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 **) +let rec abstract_status_rect_Type2 h_mk_abstract_status x_22386 = + let { as_pc = as_pc0; as_pc_of = as_pc_of0; as_classify = as_classify0; + as_label_of_pc = as_label_of_pc0; as_result = as_result0; as_call_ident = + as_call_ident0; as_tailcall_ident = as_tailcall_ident0 } = x_22386 + in + h_mk_abstract_status __ __ as_pc0 as_pc_of0 as_classify0 as_label_of_pc0 __ + as_result0 as_call_ident0 as_tailcall_ident0 + +(** val abstract_status_rect_Type1 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ + -> CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 **) +let rec abstract_status_rect_Type1 h_mk_abstract_status x_22388 = + let { as_pc = as_pc0; as_pc_of = as_pc_of0; as_classify = as_classify0; + as_label_of_pc = as_label_of_pc0; as_result = as_result0; as_call_ident = + as_call_ident0; as_tailcall_ident = as_tailcall_ident0 } = x_22388 + in + h_mk_abstract_status __ __ as_pc0 as_pc_of0 as_classify0 as_label_of_pc0 __ + as_result0 as_call_ident0 as_tailcall_ident0 + +(** val abstract_status_rect_Type0 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ + -> CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 **) +let rec abstract_status_rect_Type0 h_mk_abstract_status x_22390 = + let { as_pc = as_pc0; as_pc_of = as_pc_of0; as_classify = as_classify0; + as_label_of_pc = as_label_of_pc0; as_result = as_result0; as_call_ident = + as_call_ident0; as_tailcall_ident = as_tailcall_ident0 } = x_22390 + in + h_mk_abstract_status __ __ as_pc0 as_pc_of0 as_classify0 as_label_of_pc0 __ + as_result0 as_call_ident0 as_tailcall_ident0 + +type as_status = __ + +(** val as_pc : abstract_status -> Deqsets.deqSet **) +let rec as_pc xxx = + xxx.as_pc + +(** val as_pc_of : abstract_status -> __ -> __ **) +let rec as_pc_of xxx = + xxx.as_pc_of + +(** val as_classify : abstract_status -> __ -> status_class **) +let rec as_classify xxx = + xxx.as_classify + +(** val as_label_of_pc : + abstract_status -> __ -> CostLabel.costlabel Types.option **) +let rec as_label_of_pc xxx = + xxx.as_label_of_pc + +(** val as_result : abstract_status -> __ -> Integers.int Types.option **) +let rec as_result xxx = + xxx.as_result + +(** val as_call_ident : abstract_status -> __ Types.sig0 -> AST.ident **) +let rec as_call_ident xxx = + xxx.as_call_ident + +(** val as_tailcall_ident : abstract_status -> __ Types.sig0 -> AST.ident **) +let rec as_tailcall_ident xxx = + xxx.as_tailcall_ident + +(** val abstract_status_inv_rect_Type4 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let abstract_status_inv_rect_Type4 hterm h1 = + let hcut = abstract_status_rect_Type4 h1 hterm in hcut __ + +(** val abstract_status_inv_rect_Type3 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let abstract_status_inv_rect_Type3 hterm h1 = + let hcut = abstract_status_rect_Type3 h1 hterm in hcut __ + +(** val abstract_status_inv_rect_Type2 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let abstract_status_inv_rect_Type2 hterm h1 = + let hcut = abstract_status_rect_Type2 h1 hterm in hcut __ + +(** val abstract_status_inv_rect_Type1 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let abstract_status_inv_rect_Type1 hterm h1 = + let hcut = abstract_status_rect_Type1 h1 hterm in hcut __ + +(** val abstract_status_inv_rect_Type0 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 **) +let abstract_status_inv_rect_Type0 hterm h1 = + let hcut = abstract_status_rect_Type0 h1 hterm in hcut __ + +(** val abstract_status_jmdiscr : + abstract_status -> abstract_status -> __ **) +let abstract_status_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { as_pc = a2; as_pc_of = a3; as_classify = a4; as_label_of_pc = a5; + as_result = a7; as_call_ident = a8; as_tailcall_ident = a9 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __)) y + +(** val as_label : + abstract_status -> __ -> CostLabel.costlabel Types.option **) +let as_label s s0 = + s.as_label_of_pc (s.as_pc_of s0) + +(** val as_costed_exc : abstract_status -> __ -> (__, __) Types.sum **) +let as_costed_exc s s0 = + match as_label s s0 with + | Types.None -> Types.Inr __ + | Types.Some c -> Types.Inl __ + +type as_cost_label = CostLabel.costlabel Types.sig0 + +type as_cost_labels = as_cost_label List.list + +(** val as_cost_get_label : + abstract_status -> as_cost_label -> CostLabel.costlabel **) +let as_cost_get_label s l_sig = + Types.pi1 l_sig + +type as_cost_map = as_cost_label -> Nat.nat + +(** val as_label_safe : abstract_status -> __ Types.sig0 -> as_cost_label **) +let as_label_safe a_s st_sig = + Option.opt_safe (as_label a_s (Types.pi1 st_sig)) + +(** val lift_sigma_map_id : + 'a2 -> ('a1 -> (__, __) Types.sum) -> ('a1 Types.sig0 -> 'a2) -> 'a1 + Types.sig0 -> 'a2 **) +let lift_sigma_map_id dflt dec m a_sig = + match dec (Types.pi1 a_sig) with + | Types.Inl _ -> m (Types.pi1 a_sig) + | Types.Inr _ -> dflt + +(** val lift_cost_map_id : + abstract_status -> abstract_status -> (CostLabel.costlabel -> (__, __) + Types.sum) -> as_cost_map -> as_cost_map **) +let lift_cost_map_id s_in s_out = + lift_sigma_map_id Nat.O + +type trace_ends_with_ret = +| Ends_with_ret +| Doesnt_end_with_ret + +(** val trace_ends_with_ret_rect_Type4 : + 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 **) +let rec trace_ends_with_ret_rect_Type4 h_ends_with_ret h_doesnt_end_with_ret = function +| Ends_with_ret -> h_ends_with_ret +| Doesnt_end_with_ret -> h_doesnt_end_with_ret + +(** val trace_ends_with_ret_rect_Type5 : + 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 **) +let rec trace_ends_with_ret_rect_Type5 h_ends_with_ret h_doesnt_end_with_ret = function +| Ends_with_ret -> h_ends_with_ret +| Doesnt_end_with_ret -> h_doesnt_end_with_ret + +(** val trace_ends_with_ret_rect_Type3 : + 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 **) +let rec trace_ends_with_ret_rect_Type3 h_ends_with_ret h_doesnt_end_with_ret = function +| Ends_with_ret -> h_ends_with_ret +| Doesnt_end_with_ret -> h_doesnt_end_with_ret + +(** val trace_ends_with_ret_rect_Type2 : + 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 **) +let rec trace_ends_with_ret_rect_Type2 h_ends_with_ret h_doesnt_end_with_ret = function +| Ends_with_ret -> h_ends_with_ret +| Doesnt_end_with_ret -> h_doesnt_end_with_ret + +(** val trace_ends_with_ret_rect_Type1 : + 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 **) +let rec trace_ends_with_ret_rect_Type1 h_ends_with_ret h_doesnt_end_with_ret = function +| Ends_with_ret -> h_ends_with_ret +| Doesnt_end_with_ret -> h_doesnt_end_with_ret + +(** val trace_ends_with_ret_rect_Type0 : + 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 **) +let rec trace_ends_with_ret_rect_Type0 h_ends_with_ret h_doesnt_end_with_ret = function +| Ends_with_ret -> h_ends_with_ret +| Doesnt_end_with_ret -> h_doesnt_end_with_ret + +(** val trace_ends_with_ret_inv_rect_Type4 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let trace_ends_with_ret_inv_rect_Type4 hterm h1 h2 = + let hcut = trace_ends_with_ret_rect_Type4 h1 h2 hterm in hcut __ + +(** val trace_ends_with_ret_inv_rect_Type3 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let trace_ends_with_ret_inv_rect_Type3 hterm h1 h2 = + let hcut = trace_ends_with_ret_rect_Type3 h1 h2 hterm in hcut __ + +(** val trace_ends_with_ret_inv_rect_Type2 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let trace_ends_with_ret_inv_rect_Type2 hterm h1 h2 = + let hcut = trace_ends_with_ret_rect_Type2 h1 h2 hterm in hcut __ + +(** val trace_ends_with_ret_inv_rect_Type1 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let trace_ends_with_ret_inv_rect_Type1 hterm h1 h2 = + let hcut = trace_ends_with_ret_rect_Type1 h1 h2 hterm in hcut __ + +(** val trace_ends_with_ret_inv_rect_Type0 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let trace_ends_with_ret_inv_rect_Type0 hterm h1 h2 = + let hcut = trace_ends_with_ret_rect_Type0 h1 h2 hterm in hcut __ + +(** val trace_ends_with_ret_discr : + trace_ends_with_ret -> trace_ends_with_ret -> __ **) +let trace_ends_with_ret_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Ends_with_ret -> Obj.magic (fun _ dH -> dH) + | Doesnt_end_with_ret -> Obj.magic (fun _ dH -> dH)) y + +(** val trace_ends_with_ret_jmdiscr : + trace_ends_with_ret -> trace_ends_with_ret -> __ **) +let trace_ends_with_ret_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Ends_with_ret -> Obj.magic (fun _ dH -> dH) + | Doesnt_end_with_ret -> Obj.magic (fun _ dH -> dH)) y + +type trace_label_return = +| Tlr_base of __ * __ * trace_label_label +| Tlr_step of __ * __ * __ * trace_label_label * trace_label_return +and trace_label_label = +| Tll_base of trace_ends_with_ret * __ * __ * trace_any_label +and trace_any_label = +| Tal_base_not_return of __ * __ +| Tal_base_return of __ * __ +| Tal_base_call of __ * __ * __ * trace_label_return +| Tal_base_tailcall of __ * __ * __ * trace_label_return +| Tal_step_call of trace_ends_with_ret * __ * __ * __ * __ + * trace_label_return * trace_any_label +| Tal_step_default of trace_ends_with_ret * __ * __ * __ * trace_any_label + +(** val trace_label_return_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_return_inv_rect_Type4 x1 x2 x3 hterm h1 h2 = + let hcut = + match hterm with + | Tlr_base (x, x0, x4) -> h1 x x0 x4 + | Tlr_step (x, x0, x4, x5, x6) -> h2 x x0 x4 x5 x6 + in + hcut __ __ __ + +(** val trace_label_return_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_return_inv_rect_Type3 x1 x2 x3 hterm h1 h2 = + let hcut = + match hterm with + | Tlr_base (x, x0, x4) -> h1 x x0 x4 + | Tlr_step (x, x0, x4, x5, x6) -> h2 x x0 x4 x5 x6 + in + hcut __ __ __ + +(** val trace_label_return_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_return_inv_rect_Type2 x1 x2 x3 hterm h1 h2 = + let hcut = + match hterm with + | Tlr_base (x, x0, x4) -> h1 x x0 x4 + | Tlr_step (x, x0, x4, x5, x6) -> h2 x x0 x4 x5 x6 + in + hcut __ __ __ + +(** val trace_label_return_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_return_inv_rect_Type1 x1 x2 x3 hterm h1 h2 = + let hcut = + match hterm with + | Tlr_base (x, x0, x4) -> h1 x x0 x4 + | Tlr_step (x, x0, x4, x5, x6) -> h2 x x0 x4 x5 x6 + in + hcut __ __ __ + +(** val trace_label_return_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_return_inv_rect_Type0 x1 x2 x3 hterm h1 h2 = + let hcut = + match hterm with + | Tlr_base (x, x0, x4) -> h1 x x0 x4 + | Tlr_step (x, x0, x4, x5, x6) -> h2 x x0 x4 x5 x6 + in + hcut __ __ __ + +(** val trace_label_label_inv_rect_Type4 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_label_inv_rect_Type4 x1 x2 x3 x4 hterm h1 = + let hcut = let Tll_base (x, x0, x5, x6) = hterm in h1 x x0 x5 x6 __ in + hcut __ __ __ __ + +(** val trace_label_label_inv_rect_Type3 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_label_inv_rect_Type3 x1 x2 x3 x4 hterm h1 = + let hcut = let Tll_base (x, x0, x5, x6) = hterm in h1 x x0 x5 x6 __ in + hcut __ __ __ __ + +(** val trace_label_label_inv_rect_Type2 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_label_inv_rect_Type2 x1 x2 x3 x4 hterm h1 = + let hcut = let Tll_base (x, x0, x5, x6) = hterm in h1 x x0 x5 x6 __ in + hcut __ __ __ __ + +(** val trace_label_label_inv_rect_Type1 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_label_inv_rect_Type1 x1 x2 x3 x4 hterm h1 = + let hcut = let Tll_base (x, x0, x5, x6) = hterm in h1 x x0 x5 x6 __ in + hcut __ __ __ __ + +(** val trace_label_label_inv_rect_Type0 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ + -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_label_inv_rect_Type0 x1 x2 x3 x4 hterm h1 = + let hcut = let Tll_base (x, x0, x5, x6) = hterm in h1 x x0 x5 x6 __ in + hcut __ __ __ __ + +(** val trace_any_label_inv_rect_Type4 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ + -> 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> + 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_label_inv_rect_Type4 x1 x2 x3 x4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = + match hterm with + | Tal_base_not_return (x, x0) -> h1 x x0 __ __ __ + | Tal_base_return (x, x0) -> h2 x x0 __ __ + | Tal_base_call (x, x0, x5, x6) -> h3 x x0 x5 __ __ __ x6 __ + | Tal_base_tailcall (x, x0, x5, x6) -> h4 x x0 x5 __ __ x6 + | Tal_step_call (x, x0, x5, x6, x7, x8, x9) -> + h5 x x0 x5 x6 x7 __ __ __ x8 __ x9 + | Tal_step_default (x, x0, x5, x6, x7) -> h6 x x0 x5 x6 __ x7 __ __ + in + hcut __ __ __ __ + +(** val trace_any_label_inv_rect_Type3 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ + -> 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> + 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_label_inv_rect_Type3 x1 x2 x3 x4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = + match hterm with + | Tal_base_not_return (x, x0) -> h1 x x0 __ __ __ + | Tal_base_return (x, x0) -> h2 x x0 __ __ + | Tal_base_call (x, x0, x5, x6) -> h3 x x0 x5 __ __ __ x6 __ + | Tal_base_tailcall (x, x0, x5, x6) -> h4 x x0 x5 __ __ x6 + | Tal_step_call (x, x0, x5, x6, x7, x8, x9) -> + h5 x x0 x5 x6 x7 __ __ __ x8 __ x9 + | Tal_step_default (x, x0, x5, x6, x7) -> h6 x x0 x5 x6 __ x7 __ __ + in + hcut __ __ __ __ + +(** val trace_any_label_inv_rect_Type2 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ + -> 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> + 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_label_inv_rect_Type2 x1 x2 x3 x4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = + match hterm with + | Tal_base_not_return (x, x0) -> h1 x x0 __ __ __ + | Tal_base_return (x, x0) -> h2 x x0 __ __ + | Tal_base_call (x, x0, x5, x6) -> h3 x x0 x5 __ __ __ x6 __ + | Tal_base_tailcall (x, x0, x5, x6) -> h4 x x0 x5 __ __ x6 + | Tal_step_call (x, x0, x5, x6, x7, x8, x9) -> + h5 x x0 x5 x6 x7 __ __ __ x8 __ x9 + | Tal_step_default (x, x0, x5, x6, x7) -> h6 x x0 x5 x6 __ x7 __ __ + in + hcut __ __ __ __ + +(** val trace_any_label_inv_rect_Type1 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ + -> 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> + 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_label_inv_rect_Type1 x1 x2 x3 x4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = + match hterm with + | Tal_base_not_return (x, x0) -> h1 x x0 __ __ __ + | Tal_base_return (x, x0) -> h2 x x0 __ __ + | Tal_base_call (x, x0, x5, x6) -> h3 x x0 x5 __ __ __ x6 __ + | Tal_base_tailcall (x, x0, x5, x6) -> h4 x x0 x5 __ __ x6 + | Tal_step_call (x, x0, x5, x6, x7, x8, x9) -> + h5 x x0 x5 x6 x7 __ __ __ x8 __ x9 + | Tal_step_default (x, x0, x5, x6, x7) -> h6 x x0 x5 x6 __ x7 __ __ + in + hcut __ __ __ __ + +(** val trace_any_label_inv_rect_Type0 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ + -> 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> + 'a1) -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label + -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_label_inv_rect_Type0 x1 x2 x3 x4 hterm h1 h2 h3 h4 h5 h6 = + let hcut = + match hterm with + | Tal_base_not_return (x, x0) -> h1 x x0 __ __ __ + | Tal_base_return (x, x0) -> h2 x x0 __ __ + | Tal_base_call (x, x0, x5, x6) -> h3 x x0 x5 __ __ __ x6 __ + | Tal_base_tailcall (x, x0, x5, x6) -> h4 x x0 x5 __ __ x6 + | Tal_step_call (x, x0, x5, x6, x7, x8, x9) -> + h5 x x0 x5 x6 x7 __ __ __ x8 __ x9 + | Tal_step_default (x, x0, x5, x6, x7) -> h6 x x0 x5 x6 __ x7 __ __ + in + hcut __ __ __ __ + +(** val trace_label_return_discr : + abstract_status -> __ -> __ -> trace_label_return -> trace_label_return + -> __ **) +let trace_label_return_discr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (match x with + | Tlr_base (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Tlr_step (a0, a10, a20, a30, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val trace_label_label_discr : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> trace_label_label -> __ **) +let trace_label_label_discr a1 a2 a3 a4 x y = + Logic.eq_rect_Type2 x + (let Tll_base (a0, a10, a20, a30) = x in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val trace_label_return_jmdiscr : + abstract_status -> __ -> __ -> trace_label_return -> trace_label_return + -> __ **) +let trace_label_return_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (match x with + | Tlr_base (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __) + | Tlr_step (a0, a10, a20, a30, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val trace_label_label_jmdiscr : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> trace_label_label -> __ **) +let trace_label_label_jmdiscr a1 a2 a3 a4 x y = + Logic.eq_rect_Type2 x + (let Tll_base (a0, a10, a20, a30) = x in + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val trace_any_label_jmdiscr : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + trace_any_label -> __ **) +let trace_any_label_jmdiscr a1 a2 a3 a4 x y = + Logic.eq_rect_Type2 x + (match x with + | Tal_base_not_return (a0, a10) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __) + | Tal_base_return (a0, a10) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Tal_base_call (a0, a10, a20, a6) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __) + | Tal_base_tailcall (a0, a10, a20, a5) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __) + | Tal_step_call (a0, a10, a20, a30, a40, a8, a100) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __) + | Tal_step_default (a0, a10, a20, a30, a5) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __)) y + +(** val tal_pc_list : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + __ List.list **) +let rec tal_pc_list s fl st1 st2 = function +| Tal_base_not_return (pre, x) -> List.Cons ((s.as_pc_of pre), List.Nil) +| Tal_base_return (pre, x) -> List.Cons ((s.as_pc_of pre), List.Nil) +| Tal_base_call (pre, x, x0, x4) -> List.Cons ((s.as_pc_of pre), List.Nil) +| Tal_base_tailcall (pre, x, x0, x3) -> + List.Cons ((s.as_pc_of pre), List.Nil) +| Tal_step_call (fl', pre, x, st1', st2', x3, tl) -> + List.Cons ((s.as_pc_of pre), (tal_pc_list s fl' st1' st2' tl)) +| Tal_step_default (fl', pre, st1', st2', tl) -> + List.Cons ((s.as_pc_of pre), (tal_pc_list s fl' st1' st2' tl)) + +(** val as_trace_any_label_length' : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + Nat.nat **) +let as_trace_any_label_length' s trace_ends_flag start_status final_status the_trace = + List.length + (tal_pc_list s trace_ends_flag start_status final_status the_trace) + +(** val tll_hd_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> CostLabel.costlabel **) +let tll_hd_label s fl st1 st2 tr = + (let Tll_base (x, st1', x0, x1) = tr in + (fun _ _ _ _ -> Types.pi1 (as_label_safe s st1'))) __ __ __ __ + +(** val tlr_hd_label : + abstract_status -> __ -> __ -> trace_label_return -> CostLabel.costlabel **) +let tlr_hd_label s st1 st2 = function +| Tlr_base (st1', st2', tll) -> tll_hd_label s Ends_with_ret st1' st2' tll +| Tlr_step (st1', st2', x, tll, x0) -> + tll_hd_label s Doesnt_end_with_ret st1' st2' tll + +type trace_any_call = +| Tac_base of __ +| Tac_step_call of __ * __ * __ * __ * trace_label_return * trace_any_call +| Tac_step_default of __ * __ * __ * trace_any_call + +(** val trace_any_call_rect_Type4 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> + __ -> trace_any_call -> 'a1 **) +let rec trace_any_call_rect_Type4 s h_tac_base h_tac_step_call h_tac_step_default x_22468 x_22467 = function +| Tac_base status -> h_tac_base status __ +| Tac_step_call + (status_pre_fun_call, status_after_fun_call, status_final, + status_start_fun_call, x_22473, x_22471) -> + h_tac_step_call status_pre_fun_call status_after_fun_call status_final + status_start_fun_call __ __ __ x_22473 __ x_22471 + (trace_any_call_rect_Type4 s h_tac_base h_tac_step_call + h_tac_step_default status_after_fun_call status_final x_22471) +| Tac_step_default (status_pre, status_end, status_init, x_22478) -> + h_tac_step_default status_pre status_end status_init __ x_22478 __ __ + (trace_any_call_rect_Type4 s h_tac_base h_tac_step_call + h_tac_step_default status_init status_end x_22478) + +(** val trace_any_call_rect_Type3 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> + __ -> trace_any_call -> 'a1 **) +let rec trace_any_call_rect_Type3 s h_tac_base h_tac_step_call h_tac_step_default x_22500 x_22499 = function +| Tac_base status -> h_tac_base status __ +| Tac_step_call + (status_pre_fun_call, status_after_fun_call, status_final, + status_start_fun_call, x_22505, x_22503) -> + h_tac_step_call status_pre_fun_call status_after_fun_call status_final + status_start_fun_call __ __ __ x_22505 __ x_22503 + (trace_any_call_rect_Type3 s h_tac_base h_tac_step_call + h_tac_step_default status_after_fun_call status_final x_22503) +| Tac_step_default (status_pre, status_end, status_init, x_22510) -> + h_tac_step_default status_pre status_end status_init __ x_22510 __ __ + (trace_any_call_rect_Type3 s h_tac_base h_tac_step_call + h_tac_step_default status_init status_end x_22510) + +(** val trace_any_call_rect_Type2 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> + __ -> trace_any_call -> 'a1 **) +let rec trace_any_call_rect_Type2 s h_tac_base h_tac_step_call h_tac_step_default x_22516 x_22515 = function +| Tac_base status -> h_tac_base status __ +| Tac_step_call + (status_pre_fun_call, status_after_fun_call, status_final, + status_start_fun_call, x_22521, x_22519) -> + h_tac_step_call status_pre_fun_call status_after_fun_call status_final + status_start_fun_call __ __ __ x_22521 __ x_22519 + (trace_any_call_rect_Type2 s h_tac_base h_tac_step_call + h_tac_step_default status_after_fun_call status_final x_22519) +| Tac_step_default (status_pre, status_end, status_init, x_22526) -> + h_tac_step_default status_pre status_end status_init __ x_22526 __ __ + (trace_any_call_rect_Type2 s h_tac_base h_tac_step_call + h_tac_step_default status_init status_end x_22526) + +(** val trace_any_call_rect_Type1 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> + __ -> trace_any_call -> 'a1 **) +let rec trace_any_call_rect_Type1 s h_tac_base h_tac_step_call h_tac_step_default x_22532 x_22531 = function +| Tac_base status -> h_tac_base status __ +| Tac_step_call + (status_pre_fun_call, status_after_fun_call, status_final, + status_start_fun_call, x_22537, x_22535) -> + h_tac_step_call status_pre_fun_call status_after_fun_call status_final + status_start_fun_call __ __ __ x_22537 __ x_22535 + (trace_any_call_rect_Type1 s h_tac_base h_tac_step_call + h_tac_step_default status_after_fun_call status_final x_22535) +| Tac_step_default (status_pre, status_end, status_init, x_22542) -> + h_tac_step_default status_pre status_end status_init __ x_22542 __ __ + (trace_any_call_rect_Type1 s h_tac_base h_tac_step_call + h_tac_step_default status_init status_end x_22542) + +(** val trace_any_call_rect_Type0 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> + __ -> trace_any_call -> 'a1 **) +let rec trace_any_call_rect_Type0 s h_tac_base h_tac_step_call h_tac_step_default x_22548 x_22547 = function +| Tac_base status -> h_tac_base status __ +| Tac_step_call + (status_pre_fun_call, status_after_fun_call, status_final, + status_start_fun_call, x_22553, x_22551) -> + h_tac_step_call status_pre_fun_call status_after_fun_call status_final + status_start_fun_call __ __ __ x_22553 __ x_22551 + (trace_any_call_rect_Type0 s h_tac_base h_tac_step_call + h_tac_step_default status_after_fun_call status_final x_22551) +| Tac_step_default (status_pre, status_end, status_init, x_22558) -> + h_tac_step_default status_pre status_end status_init __ x_22558 __ __ + (trace_any_call_rect_Type0 s h_tac_base h_tac_step_call + h_tac_step_default status_init status_end x_22558) + +(** val trace_any_call_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> + __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ + -> __ -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_call_inv_rect_Type4 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_call_rect_Type4 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_call_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> + __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ + -> __ -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_call_inv_rect_Type3 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_call_rect_Type3 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_call_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> + __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ + -> __ -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_call_inv_rect_Type2 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_call_rect_Type2 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_call_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> + __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ + -> __ -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_call_inv_rect_Type1 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_call_rect_Type1 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_call_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> + __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ + -> __ -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_call_inv_rect_Type0 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_call_rect_Type0 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_call_jmdiscr : + abstract_status -> __ -> __ -> trace_any_call -> trace_any_call -> __ **) +let trace_any_call_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (match x with + | Tac_base a0 -> Obj.magic (fun _ dH -> dH __ __) + | Tac_step_call (a0, a10, a20, a30, a7, a9) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __) + | Tac_step_default (a0, a10, a20, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) y + +type trace_label_call = +| Tlc_base of __ * __ * trace_any_call + +(** val trace_label_call_rect_Type4 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ + -> trace_label_call -> 'a1 **) +let rec trace_label_call_rect_Type4 s h_tlc_base x_22666 x_22665 = function +| Tlc_base (start_status, end_status, x_22669) -> + h_tlc_base start_status end_status x_22669 __ + +(** val trace_label_call_rect_Type5 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ + -> trace_label_call -> 'a1 **) +let rec trace_label_call_rect_Type5 s h_tlc_base x_22672 x_22671 = function +| Tlc_base (start_status, end_status, x_22675) -> + h_tlc_base start_status end_status x_22675 __ + +(** val trace_label_call_rect_Type3 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ + -> trace_label_call -> 'a1 **) +let rec trace_label_call_rect_Type3 s h_tlc_base x_22678 x_22677 = function +| Tlc_base (start_status, end_status, x_22681) -> + h_tlc_base start_status end_status x_22681 __ + +(** val trace_label_call_rect_Type2 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ + -> trace_label_call -> 'a1 **) +let rec trace_label_call_rect_Type2 s h_tlc_base x_22684 x_22683 = function +| Tlc_base (start_status, end_status, x_22687) -> + h_tlc_base start_status end_status x_22687 __ + +(** val trace_label_call_rect_Type1 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ + -> trace_label_call -> 'a1 **) +let rec trace_label_call_rect_Type1 s h_tlc_base x_22690 x_22689 = function +| Tlc_base (start_status, end_status, x_22693) -> + h_tlc_base start_status end_status x_22693 __ + +(** val trace_label_call_rect_Type0 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ + -> trace_label_call -> 'a1 **) +let rec trace_label_call_rect_Type0 s h_tlc_base x_22696 x_22695 = function +| Tlc_base (start_status, end_status, x_22699) -> + h_tlc_base start_status end_status x_22699 __ + +(** val trace_label_call_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_call_inv_rect_Type4 x1 x2 x3 hterm h1 = + let hcut = trace_label_call_rect_Type4 x1 h1 x2 x3 hterm in hcut __ __ __ + +(** val trace_label_call_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_call_inv_rect_Type3 x1 x2 x3 hterm h1 = + let hcut = trace_label_call_rect_Type3 x1 h1 x2 x3 hterm in hcut __ __ __ + +(** val trace_label_call_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_call_inv_rect_Type2 x1 x2 x3 hterm h1 = + let hcut = trace_label_call_rect_Type2 x1 h1 x2 x3 hterm in hcut __ __ __ + +(** val trace_label_call_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_call_inv_rect_Type1 x1 x2 x3 hterm h1 = + let hcut = trace_label_call_rect_Type1 x1 h1 x2 x3 hterm in hcut __ __ __ + +(** val trace_label_call_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_label_call_inv_rect_Type0 x1 x2 x3 hterm h1 = + let hcut = trace_label_call_rect_Type0 x1 h1 x2 x3 hterm in hcut __ __ __ + +(** val trace_label_call_discr : + abstract_status -> __ -> __ -> trace_label_call -> trace_label_call -> __ **) +let trace_label_call_discr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (let Tlc_base (a0, a10, a20) = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val trace_label_call_jmdiscr : + abstract_status -> __ -> __ -> trace_label_call -> trace_label_call -> __ **) +let trace_label_call_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (let Tlc_base (a0, a10, a20) = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val tlc_hd_label : + abstract_status -> __ -> __ -> trace_label_call -> CostLabel.costlabel **) +let tlc_hd_label s st1 st2 tr = + (let Tlc_base (st1', x, x0) = tr in + (fun _ _ _ -> Types.pi1 (as_label_safe s st1'))) __ __ __ + +type trace_label_diverges = __trace_label_diverges Lazy.t +and __trace_label_diverges = +| Tld_step of __ * __ * trace_label_label * trace_label_diverges +| Tld_base of __ * __ * __ * trace_label_call * trace_label_diverges + +(** val trace_label_diverges_inv_rect_Type4 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> + __ -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> + __ -> 'a1) -> 'a1 **) +let trace_label_diverges_inv_rect_Type4 x1 x2 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Tld_step (x, x0, x3, x4) -> h1 x x0 x3 x4 + | Tld_base (x, x0, x3, x4, x5) -> h2 x x0 x3 x4 __ __ x5 + in + hcut __ __ + +(** val trace_label_diverges_inv_rect_Type3 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> + __ -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> + __ -> 'a1) -> 'a1 **) +let trace_label_diverges_inv_rect_Type3 x1 x2 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Tld_step (x, x0, x3, x4) -> h1 x x0 x3 x4 + | Tld_base (x, x0, x3, x4, x5) -> h2 x x0 x3 x4 __ __ x5 + in + hcut __ __ + +(** val trace_label_diverges_inv_rect_Type2 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> + __ -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> + __ -> 'a1) -> 'a1 **) +let trace_label_diverges_inv_rect_Type2 x1 x2 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Tld_step (x, x0, x3, x4) -> h1 x x0 x3 x4 + | Tld_base (x, x0, x3, x4, x5) -> h2 x x0 x3 x4 __ __ x5 + in + hcut __ __ + +(** val trace_label_diverges_inv_rect_Type1 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> + __ -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> + __ -> 'a1) -> 'a1 **) +let trace_label_diverges_inv_rect_Type1 x1 x2 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Tld_step (x, x0, x3, x4) -> h1 x x0 x3 x4 + | Tld_base (x, x0, x3, x4, x5) -> h2 x x0 x3 x4 __ __ x5 + in + hcut __ __ + +(** val trace_label_diverges_inv_rect_Type0 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> + __ -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> + __ -> 'a1) -> 'a1 **) +let trace_label_diverges_inv_rect_Type0 x1 x2 hterm h1 h2 = + let hcut = + match Lazy.force + hterm with + | Tld_step (x, x0, x3, x4) -> h1 x x0 x3 x4 + | Tld_base (x, x0, x3, x4, x5) -> h2 x x0 x3 x4 __ __ x5 + in + hcut __ __ + +(** val trace_label_diverges_jmdiscr : + abstract_status -> __ -> trace_label_diverges -> trace_label_diverges -> + __ **) +let trace_label_diverges_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match Lazy.force + x with + | Tld_step (a0, a10, a20, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Tld_base (a0, a10, a20, a3, a6) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) y + +(** val tld_hd_label : + abstract_status -> __ -> trace_label_diverges -> CostLabel.costlabel **) +let tld_hd_label s st tr = + match Lazy.force + tr with + | Tld_step (st', st'', tll, x) -> + tll_hd_label s Doesnt_end_with_ret st' st'' tll + | Tld_base (st', st'', x, tlc, x2) -> tlc_hd_label s st' st'' tlc + +type trace_whole_program = +| Twp_terminating of __ * __ * __ * trace_label_return +| Twp_diverges of __ * __ * trace_label_diverges + +(** val trace_whole_program_rect_Type4 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ + -> trace_whole_program -> 'a1 **) +let rec trace_whole_program_rect_Type4 s h_twp_terminating h_twp_diverges x_22748 = function +| Twp_terminating + (status_initial, status_start_fun, status_final, x_22751) -> + h_twp_terminating status_initial status_start_fun status_final __ __ + x_22751 __ +| Twp_diverges (status_initial, status_start_fun, x_22754) -> + h_twp_diverges status_initial status_start_fun __ __ x_22754 + +(** val trace_whole_program_rect_Type5 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ + -> trace_whole_program -> 'a1 **) +let rec trace_whole_program_rect_Type5 s h_twp_terminating h_twp_diverges x_22759 = function +| Twp_terminating + (status_initial, status_start_fun, status_final, x_22762) -> + h_twp_terminating status_initial status_start_fun status_final __ __ + x_22762 __ +| Twp_diverges (status_initial, status_start_fun, x_22765) -> + h_twp_diverges status_initial status_start_fun __ __ x_22765 + +(** val trace_whole_program_rect_Type3 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ + -> trace_whole_program -> 'a1 **) +let rec trace_whole_program_rect_Type3 s h_twp_terminating h_twp_diverges x_22770 = function +| Twp_terminating + (status_initial, status_start_fun, status_final, x_22773) -> + h_twp_terminating status_initial status_start_fun status_final __ __ + x_22773 __ +| Twp_diverges (status_initial, status_start_fun, x_22776) -> + h_twp_diverges status_initial status_start_fun __ __ x_22776 + +(** val trace_whole_program_rect_Type2 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ + -> trace_whole_program -> 'a1 **) +let rec trace_whole_program_rect_Type2 s h_twp_terminating h_twp_diverges x_22781 = function +| Twp_terminating + (status_initial, status_start_fun, status_final, x_22784) -> + h_twp_terminating status_initial status_start_fun status_final __ __ + x_22784 __ +| Twp_diverges (status_initial, status_start_fun, x_22787) -> + h_twp_diverges status_initial status_start_fun __ __ x_22787 + +(** val trace_whole_program_rect_Type1 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ + -> trace_whole_program -> 'a1 **) +let rec trace_whole_program_rect_Type1 s h_twp_terminating h_twp_diverges x_22792 = function +| Twp_terminating + (status_initial, status_start_fun, status_final, x_22795) -> + h_twp_terminating status_initial status_start_fun status_final __ __ + x_22795 __ +| Twp_diverges (status_initial, status_start_fun, x_22798) -> + h_twp_diverges status_initial status_start_fun __ __ x_22798 + +(** val trace_whole_program_rect_Type0 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ + -> trace_whole_program -> 'a1 **) +let rec trace_whole_program_rect_Type0 s h_twp_terminating h_twp_diverges x_22803 = function +| Twp_terminating + (status_initial, status_start_fun, status_final, x_22806) -> + h_twp_terminating status_initial status_start_fun status_final __ __ + x_22806 __ +| Twp_diverges (status_initial, status_start_fun, x_22809) -> + h_twp_diverges status_initial status_start_fun __ __ x_22809 + +(** val trace_whole_program_inv_rect_Type4 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + __ -> trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 **) +let trace_whole_program_inv_rect_Type4 x1 x2 hterm h1 h2 = + let hcut = trace_whole_program_rect_Type4 x1 h1 h2 x2 hterm in hcut __ __ + +(** val trace_whole_program_inv_rect_Type3 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + __ -> trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 **) +let trace_whole_program_inv_rect_Type3 x1 x2 hterm h1 h2 = + let hcut = trace_whole_program_rect_Type3 x1 h1 h2 x2 hterm in hcut __ __ + +(** val trace_whole_program_inv_rect_Type2 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + __ -> trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 **) +let trace_whole_program_inv_rect_Type2 x1 x2 hterm h1 h2 = + let hcut = trace_whole_program_rect_Type2 x1 h1 h2 x2 hterm in hcut __ __ + +(** val trace_whole_program_inv_rect_Type1 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + __ -> trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 **) +let trace_whole_program_inv_rect_Type1 x1 x2 hterm h1 h2 = + let hcut = trace_whole_program_rect_Type1 x1 h1 h2 x2 hterm in hcut __ __ + +(** val trace_whole_program_inv_rect_Type0 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + __ -> trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 **) +let trace_whole_program_inv_rect_Type0 x1 x2 hterm h1 h2 = + let hcut = trace_whole_program_rect_Type0 x1 h1 h2 x2 hterm in hcut __ __ + +(** val trace_whole_program_jmdiscr : + abstract_status -> __ -> trace_whole_program -> trace_whole_program -> __ **) +let trace_whole_program_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Twp_terminating (a0, a10, a20, a5) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __) + | Twp_diverges (a0, a10, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val tal_tl_label : + abstract_status -> __ -> __ -> trace_any_label -> CostLabel.costlabel **) +let tal_tl_label s st1 st2 tr = + Types.pi1 (as_label_safe s st2) + +(** val tll_tl_label : + abstract_status -> __ -> __ -> trace_label_label -> CostLabel.costlabel **) +let tll_tl_label s st1 st2 tr = + Types.pi1 (as_label_safe s st2) + +type trace_any_any = +| Taa_base of __ +| Taa_step of __ * __ * __ * trace_any_any + +(** val trace_any_any_rect_Type4 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 **) +let rec trace_any_any_rect_Type4 s h_taa_base h_taa_step x_23033 x_23032 = function +| Taa_base st -> h_taa_base st +| Taa_step (st1, st2, st3, x_23035) -> + h_taa_step st1 st2 st3 __ __ __ x_23035 + (trace_any_any_rect_Type4 s h_taa_base h_taa_step st2 st3 x_23035) + +(** val trace_any_any_rect_Type3 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 **) +let rec trace_any_any_rect_Type3 s h_taa_base h_taa_step x_23051 x_23050 = function +| Taa_base st -> h_taa_base st +| Taa_step (st1, st2, st3, x_23053) -> + h_taa_step st1 st2 st3 __ __ __ x_23053 + (trace_any_any_rect_Type3 s h_taa_base h_taa_step st2 st3 x_23053) + +(** val trace_any_any_rect_Type2 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 **) +let rec trace_any_any_rect_Type2 s h_taa_base h_taa_step x_23060 x_23059 = function +| Taa_base st -> h_taa_base st +| Taa_step (st1, st2, st3, x_23062) -> + h_taa_step st1 st2 st3 __ __ __ x_23062 + (trace_any_any_rect_Type2 s h_taa_base h_taa_step st2 st3 x_23062) + +(** val trace_any_any_rect_Type1 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 **) +let rec trace_any_any_rect_Type1 s h_taa_base h_taa_step x_23069 x_23068 = function +| Taa_base st -> h_taa_base st +| Taa_step (st1, st2, st3, x_23071) -> + h_taa_step st1 st2 st3 __ __ __ x_23071 + (trace_any_any_rect_Type1 s h_taa_base h_taa_step st2 st3 x_23071) + +(** val trace_any_any_rect_Type0 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 **) +let rec trace_any_any_rect_Type0 s h_taa_base h_taa_step x_23078 x_23077 = function +| Taa_base st -> h_taa_base st +| Taa_step (st1, st2, st3, x_23080) -> + h_taa_step st1 st2 st3 __ __ __ x_23080 + (trace_any_any_rect_Type0 s h_taa_base h_taa_step st2 st3 x_23080) + +(** val trace_any_any_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ + -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_inv_rect_Type4 x1 x2 x3 hterm h1 h2 = + let hcut = trace_any_any_rect_Type4 x1 h1 h2 x2 x3 hterm in hcut __ __ __ + +(** val trace_any_any_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ + -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_inv_rect_Type3 x1 x2 x3 hterm h1 h2 = + let hcut = trace_any_any_rect_Type3 x1 h1 h2 x2 x3 hterm in hcut __ __ __ + +(** val trace_any_any_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ + -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_inv_rect_Type2 x1 x2 x3 hterm h1 h2 = + let hcut = trace_any_any_rect_Type2 x1 h1 h2 x2 x3 hterm in hcut __ __ __ + +(** val trace_any_any_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ + -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_inv_rect_Type1 x1 x2 x3 hterm h1 h2 = + let hcut = trace_any_any_rect_Type1 x1 h1 h2 x2 x3 hterm in hcut __ __ __ + +(** val trace_any_any_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ + -> __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_inv_rect_Type0 x1 x2 x3 hterm h1 h2 = + let hcut = trace_any_any_rect_Type0 x1 h1 h2 x2 x3 hterm in hcut __ __ __ + +(** val trace_any_any_jmdiscr : + abstract_status -> __ -> __ -> trace_any_any -> trace_any_any -> __ **) +let trace_any_any_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (match x with + | Taa_base a0 -> Obj.magic (fun _ dH -> dH __) + | Taa_step (a0, a10, a20, a6) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) y + +(** val taa_non_empty : + abstract_status -> __ -> __ -> trace_any_any -> Bool.bool **) +let taa_non_empty s st1 st2 = function +| Taa_base x -> Bool.False +| Taa_step (x, x0, x1, x5) -> Bool.True + +(** val dpi1__o__taa_to_bool__o__inject : + abstract_status -> __ -> __ -> (trace_any_any, 'a1) Types.dPair -> + Bool.bool Types.sig0 **) +let dpi1__o__taa_to_bool__o__inject x1 x2 x3 x5 = + taa_non_empty x1 x2 x3 x5.Types.dpi1 + +(** val dpi1__o__taa_to_bool__o__bool_to_Prop__o__inject : + abstract_status -> __ -> __ -> (trace_any_any, 'a1) Types.dPair -> __ + Types.sig0 **) +let dpi1__o__taa_to_bool__o__bool_to_Prop__o__inject x1 x2 x3 x5 = + Util.bool_to_Prop__o__inject (taa_non_empty x1 x2 x3 x5.Types.dpi1) + +(** val eject__o__taa_to_bool__o__inject : + abstract_status -> __ -> __ -> trace_any_any Types.sig0 -> Bool.bool + Types.sig0 **) +let eject__o__taa_to_bool__o__inject x1 x2 x3 x5 = + taa_non_empty x1 x2 x3 (Types.pi1 x5) + +(** val eject__o__taa_to_bool__o__bool_to_Prop__o__inject : + abstract_status -> __ -> __ -> trace_any_any Types.sig0 -> __ Types.sig0 **) +let eject__o__taa_to_bool__o__bool_to_Prop__o__inject x1 x2 x3 x5 = + Util.bool_to_Prop__o__inject (taa_non_empty x1 x2 x3 (Types.pi1 x5)) + +(** val taa_to_bool__o__bool_to_Prop__o__inject : + abstract_status -> __ -> __ -> trace_any_any -> __ Types.sig0 **) +let taa_to_bool__o__bool_to_Prop__o__inject x1 x2 x3 x4 = + Util.bool_to_Prop__o__inject (taa_non_empty x1 x2 x3 x4) + +(** val taa_to_bool__o__inject : + abstract_status -> __ -> __ -> trace_any_any -> Bool.bool Types.sig0 **) +let taa_to_bool__o__inject x1 x2 x3 x4 = + taa_non_empty x1 x2 x3 x4 + +(** val dpi1__o__taa_to_bool : + abstract_status -> __ -> __ -> (trace_any_any, 'a1) Types.dPair -> + Bool.bool **) +let dpi1__o__taa_to_bool x0 x1 x2 x4 = + taa_non_empty x0 x1 x2 x4.Types.dpi1 + +(** val eject__o__taa_to_bool : + abstract_status -> __ -> __ -> trace_any_any Types.sig0 -> Bool.bool **) +let eject__o__taa_to_bool x0 x1 x2 x4 = + taa_non_empty x0 x1 x2 (Types.pi1 x4) + +(** val taa_append_tal : + abstract_status -> __ -> trace_ends_with_ret -> __ -> __ -> trace_any_any + -> trace_any_label -> trace_any_label **) +let rec taa_append_tal s st1 fl st2 st3 taa = + (match taa with + | Taa_base st1' -> (fun fl0 st30 tal2 -> tal2) + | Taa_step (st1', st2', st3', tl) -> + (fun fl0 st30 tal2 -> Tal_step_default (fl0, st1', st2', st30, + (taa_append_tal s st2' fl0 st3' st30 tl tal2)))) fl st3 + +type intensional_event = +| IEVcost of CostLabel.costlabel +| IEVcall of AST.ident +| IEVtailcall of AST.ident * AST.ident +| IEVret of AST.ident + +(** val intensional_event_rect_Type4 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 **) +let rec intensional_event_rect_Type4 h_IEVcost h_IEVcall h_IEVtailcall h_IEVret = function +| IEVcost x_23151 -> h_IEVcost x_23151 +| IEVcall x_23152 -> h_IEVcall x_23152 +| IEVtailcall (x_23154, x_23153) -> h_IEVtailcall x_23154 x_23153 +| IEVret x_23155 -> h_IEVret x_23155 + +(** val intensional_event_rect_Type5 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 **) +let rec intensional_event_rect_Type5 h_IEVcost h_IEVcall h_IEVtailcall h_IEVret = function +| IEVcost x_23161 -> h_IEVcost x_23161 +| IEVcall x_23162 -> h_IEVcall x_23162 +| IEVtailcall (x_23164, x_23163) -> h_IEVtailcall x_23164 x_23163 +| IEVret x_23165 -> h_IEVret x_23165 + +(** val intensional_event_rect_Type3 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 **) +let rec intensional_event_rect_Type3 h_IEVcost h_IEVcall h_IEVtailcall h_IEVret = function +| IEVcost x_23171 -> h_IEVcost x_23171 +| IEVcall x_23172 -> h_IEVcall x_23172 +| IEVtailcall (x_23174, x_23173) -> h_IEVtailcall x_23174 x_23173 +| IEVret x_23175 -> h_IEVret x_23175 + +(** val intensional_event_rect_Type2 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 **) +let rec intensional_event_rect_Type2 h_IEVcost h_IEVcall h_IEVtailcall h_IEVret = function +| IEVcost x_23181 -> h_IEVcost x_23181 +| IEVcall x_23182 -> h_IEVcall x_23182 +| IEVtailcall (x_23184, x_23183) -> h_IEVtailcall x_23184 x_23183 +| IEVret x_23185 -> h_IEVret x_23185 + +(** val intensional_event_rect_Type1 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 **) +let rec intensional_event_rect_Type1 h_IEVcost h_IEVcall h_IEVtailcall h_IEVret = function +| IEVcost x_23191 -> h_IEVcost x_23191 +| IEVcall x_23192 -> h_IEVcall x_23192 +| IEVtailcall (x_23194, x_23193) -> h_IEVtailcall x_23194 x_23193 +| IEVret x_23195 -> h_IEVret x_23195 + +(** val intensional_event_rect_Type0 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 **) +let rec intensional_event_rect_Type0 h_IEVcost h_IEVcall h_IEVtailcall h_IEVret = function +| IEVcost x_23201 -> h_IEVcost x_23201 +| IEVcall x_23202 -> h_IEVcall x_23202 +| IEVtailcall (x_23204, x_23203) -> h_IEVtailcall x_23204 x_23203 +| IEVret x_23205 -> h_IEVret x_23205 + +(** val intensional_event_inv_rect_Type4 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> + __ -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> 'a1 **) +let intensional_event_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = intensional_event_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val intensional_event_inv_rect_Type3 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> + __ -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> 'a1 **) +let intensional_event_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = intensional_event_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val intensional_event_inv_rect_Type2 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> + __ -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> 'a1 **) +let intensional_event_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = intensional_event_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val intensional_event_inv_rect_Type1 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> + __ -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> 'a1 **) +let intensional_event_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = intensional_event_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val intensional_event_inv_rect_Type0 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> + __ -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> 'a1 **) +let intensional_event_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = intensional_event_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val intensional_event_discr : + intensional_event -> intensional_event -> __ **) +let intensional_event_discr x y = + Logic.eq_rect_Type2 x + (match x with + | IEVcost a0 -> Obj.magic (fun _ dH -> dH __) + | IEVcall a0 -> Obj.magic (fun _ dH -> dH __) + | IEVtailcall (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | IEVret a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val intensional_event_jmdiscr : + intensional_event -> intensional_event -> __ **) +let intensional_event_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | IEVcost a0 -> Obj.magic (fun _ dH -> dH __) + | IEVcall a0 -> Obj.magic (fun _ dH -> dH __) + | IEVtailcall (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | IEVret a0 -> Obj.magic (fun _ dH -> dH __)) y + +type as_trace = intensional_event List.list Types.sig0 + +(** val cons_safe : + 'a1 Types.sig0 -> 'a1 List.list Types.sig0 -> 'a1 List.list Types.sig0 **) +let cons_safe x l = + List.Cons ((Types.pi1 x), (Types.pi1 l)) + +(** val append_safe : + 'a1 List.list Types.sig0 -> 'a1 List.list Types.sig0 -> 'a1 List.list + Types.sig0 **) +let append_safe l1 l2 = + List.append (Types.pi1 l1) (Types.pi1 l2) + +(** val nil_safe : 'a1 List.list Types.sig0 **) +let nil_safe = + List.Nil + +(** val emittable_cost : + abstract_status -> as_cost_label -> intensional_event Types.sig0 **) +let emittable_cost s l = + IEVcost (Types.pi1 l) + +(** val observables_trace_label_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> AST.ident -> as_trace **) +let rec observables_trace_label_label s trace_ends_flag start_status final_status the_trace curr = + let Tll_base (ends_flag, initial, final, given_trace) = the_trace in + let label = as_label_safe s initial in + cons_safe (emittable_cost s label) + (observables_trace_any_label s ends_flag initial final given_trace curr) +(** val observables_trace_any_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + AST.ident -> as_trace **) +and observables_trace_any_label s trace_ends_flag start_status final_status the_trace curr = + match the_trace with + | Tal_base_not_return (the_status, x) -> nil_safe + | Tal_base_return (the_status, x) -> cons_safe (IEVret curr) nil_safe + | Tal_base_call (pre_fun_call, start_fun_call, final, call_trace) -> + let id = s.as_call_ident pre_fun_call in + cons_safe (IEVcall id) + (observables_trace_label_return s start_fun_call final call_trace id) + | Tal_base_tailcall (pre_fun_call, start_fun_call, final, call_trace) -> + let id = s.as_tailcall_ident pre_fun_call in + cons_safe (IEVtailcall (curr, id)) + (observables_trace_label_return s start_fun_call final call_trace id) + | Tal_step_call + (end_flag, pre_fun_call, start_fun_call, after_fun_call, final, + call_trace, final_trace) -> + let id = s.as_call_ident pre_fun_call in + let call_cost_trace = + observables_trace_label_return s start_fun_call after_fun_call + call_trace id + in + let final_cost_trace = + observables_trace_any_label s end_flag after_fun_call final final_trace + curr + in + append_safe (cons_safe (IEVcall id) call_cost_trace) final_cost_trace + | Tal_step_default + (end_flag, status_pre, status_init, status_end, tail_trace) -> + observables_trace_any_label s end_flag status_init status_end tail_trace + curr +(** val observables_trace_label_return : + abstract_status -> __ -> __ -> trace_label_return -> AST.ident -> + as_trace **) +and observables_trace_label_return s start_status final_status the_trace curr = + match the_trace with + | Tlr_base (before, after, trace_to_lift) -> + observables_trace_label_label s Ends_with_ret before after trace_to_lift + curr + | Tlr_step (initial, labelled, final, labelled_trace, ret_trace) -> + let labelled_cost = + observables_trace_label_label s Doesnt_end_with_ret initial labelled + labelled_trace curr + in + let return_cost = + observables_trace_label_return s labelled final ret_trace curr + in + append_safe labelled_cost return_cost + +(** val filter_map : + ('a1 -> 'a2 Types.option) -> 'a1 List.list -> 'a2 List.list **) +let rec filter_map f = function +| List.Nil -> List.Nil +| List.Cons (hd, tl) -> + List.append + (match f hd with + | Types.None -> List.Nil + | Types.Some y -> List.Cons (y, List.Nil)) (filter_map f tl) + +(** val list_distribute_sig_aux : + 'a1 List.list -> 'a1 Types.sig0 List.list **) +let rec list_distribute_sig_aux l = + (match l with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (hd, tl) -> + (fun _ -> List.Cons (hd, (list_distribute_sig_aux tl)))) __ + +(** val list_distribute_sig : + 'a1 List.list Types.sig0 -> 'a1 Types.sig0 List.list **) +let list_distribute_sig l = + list_distribute_sig_aux (Types.pi1 l) + +(** val list_factor_sig : + 'a1 Types.sig0 List.list -> 'a1 List.list Types.sig0 **) +let rec list_factor_sig = function +| List.Nil -> nil_safe +| List.Cons (hd, tl) -> cons_safe hd (list_factor_sig tl) + +(** val costlabels_of_observables : + abstract_status -> as_trace -> as_cost_label List.list **) +let costlabels_of_observables s l = + filter_map (fun ev -> + (match Types.pi1 ev with + | IEVcost c -> (fun _ -> Types.Some c) + | IEVcall x -> (fun _ -> Types.None) + | IEVtailcall (x, x0) -> (fun _ -> Types.None) + | IEVret x -> (fun _ -> Types.None)) __) (list_distribute_sig l) + +(** val flatten_trace_label_return : + abstract_status -> __ -> __ -> trace_label_return -> as_cost_label + List.list **) +let flatten_trace_label_return s st1 st2 tlr = + let dummy = Positive.One in + costlabels_of_observables s + (observables_trace_label_return s st1 st2 tlr dummy) + +(** val flatten_trace_label_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label + -> as_cost_label List.list **) +let flatten_trace_label_label s flag st1 st2 tll = + let dummy = Positive.One in + costlabels_of_observables s + (observables_trace_label_label s flag st1 st2 tll dummy) + +(** val flatten_trace_any_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + as_cost_label List.list **) +let flatten_trace_any_label s flag st1 st2 tll = + let dummy = Positive.One in + costlabels_of_observables s + (observables_trace_any_label s flag st1 st2 tll dummy) + +type trace_any_any_free = +| Taaf_base of __ +| Taaf_step of __ * __ * __ * trace_any_any +| Taaf_step_jump of __ * __ * __ * trace_any_any + +(** val trace_any_any_free_rect_Type4 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ + -> __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> trace_any_any_free -> 'a1 **) +let rec trace_any_any_free_rect_Type4 s h_taaf_base h_taaf_step h_taaf_step_jump x_23284 x_23283 = function +| Taaf_base s0 -> h_taaf_base s0 +| Taaf_step (s1, s2, s3, x_23288) -> h_taaf_step s1 s2 s3 x_23288 __ __ +| Taaf_step_jump (s1, s2, s3, x_23292) -> + h_taaf_step_jump s1 s2 s3 x_23292 __ __ __ + +(** val trace_any_any_free_rect_Type5 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ + -> __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> trace_any_any_free -> 'a1 **) +let rec trace_any_any_free_rect_Type5 s h_taaf_base h_taaf_step h_taaf_step_jump x_23297 x_23296 = function +| Taaf_base s0 -> h_taaf_base s0 +| Taaf_step (s1, s2, s3, x_23301) -> h_taaf_step s1 s2 s3 x_23301 __ __ +| Taaf_step_jump (s1, s2, s3, x_23305) -> + h_taaf_step_jump s1 s2 s3 x_23305 __ __ __ + +(** val trace_any_any_free_rect_Type3 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ + -> __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> trace_any_any_free -> 'a1 **) +let rec trace_any_any_free_rect_Type3 s h_taaf_base h_taaf_step h_taaf_step_jump x_23310 x_23309 = function +| Taaf_base s0 -> h_taaf_base s0 +| Taaf_step (s1, s2, s3, x_23314) -> h_taaf_step s1 s2 s3 x_23314 __ __ +| Taaf_step_jump (s1, s2, s3, x_23318) -> + h_taaf_step_jump s1 s2 s3 x_23318 __ __ __ + +(** val trace_any_any_free_rect_Type2 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ + -> __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> trace_any_any_free -> 'a1 **) +let rec trace_any_any_free_rect_Type2 s h_taaf_base h_taaf_step h_taaf_step_jump x_23323 x_23322 = function +| Taaf_base s0 -> h_taaf_base s0 +| Taaf_step (s1, s2, s3, x_23327) -> h_taaf_step s1 s2 s3 x_23327 __ __ +| Taaf_step_jump (s1, s2, s3, x_23331) -> + h_taaf_step_jump s1 s2 s3 x_23331 __ __ __ + +(** val trace_any_any_free_rect_Type1 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ + -> __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> trace_any_any_free -> 'a1 **) +let rec trace_any_any_free_rect_Type1 s h_taaf_base h_taaf_step h_taaf_step_jump x_23336 x_23335 = function +| Taaf_base s0 -> h_taaf_base s0 +| Taaf_step (s1, s2, s3, x_23340) -> h_taaf_step s1 s2 s3 x_23340 __ __ +| Taaf_step_jump (s1, s2, s3, x_23344) -> + h_taaf_step_jump s1 s2 s3 x_23344 __ __ __ + +(** val trace_any_any_free_rect_Type0 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ + -> __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> + 'a1) -> __ -> __ -> trace_any_any_free -> 'a1 **) +let rec trace_any_any_free_rect_Type0 s h_taaf_base h_taaf_step h_taaf_step_jump x_23349 x_23348 = function +| Taaf_base s0 -> h_taaf_base s0 +| Taaf_step (s1, s2, s3, x_23353) -> h_taaf_step s1 s2 s3 x_23353 __ __ +| Taaf_step_jump (s1, s2, s3, x_23357) -> + h_taaf_step_jump s1 s2 s3 x_23357 __ __ __ + +(** val trace_any_any_free_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_free_inv_rect_Type4 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_any_free_rect_Type4 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_any_free_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_free_inv_rect_Type3 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_any_free_rect_Type3 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_any_free_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_free_inv_rect_Type2 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_any_free_rect_Type2 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_any_free_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_free_inv_rect_Type1 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_any_free_rect_Type1 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_any_free_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> + __ -> __ -> 'a1) -> 'a1 **) +let trace_any_any_free_inv_rect_Type0 x1 x2 x3 hterm h1 h2 h3 = + let hcut = trace_any_any_free_rect_Type0 x1 h1 h2 h3 x2 x3 hterm in + hcut __ __ __ + +(** val trace_any_any_free_jmdiscr : + abstract_status -> __ -> __ -> trace_any_any_free -> trace_any_any_free + -> __ **) +let trace_any_any_free_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (match x with + | Taaf_base a0 -> Obj.magic (fun _ dH -> dH __) + | Taaf_step (a0, a10, a20, a30) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __) + | Taaf_step_jump (a0, a10, a20, a30) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __)) y + +(** val taaf_non_empty : + abstract_status -> __ -> __ -> trace_any_any_free -> Bool.bool **) +let taaf_non_empty s s1 s2 = function +| Taaf_base x -> Bool.False +| Taaf_step (x, x0, x1, x2) -> Bool.True +| Taaf_step_jump (x, x0, x1, x2) -> Bool.True + +(** val taa_append_taa : + abstract_status -> __ -> __ -> __ -> trace_any_any -> trace_any_any -> + trace_any_any **) +let rec taa_append_taa s st1 st2 st3 taa = + (match taa with + | Taa_base st1' -> (fun st30 taa2 -> taa2) + | Taa_step (st1', st2', st3', tl) -> + (fun st30 taa2 -> Taa_step (st1', st2', st30, + (taa_append_taa s st2' st3' st30 tl taa2)))) st3 + +(** val taaf_to_taa : + abstract_status -> __ -> __ -> trace_any_any_free -> trace_any_any **) +let taaf_to_taa s s1 s2 taaf = + (match taaf with + | Taaf_base s0 -> (fun _ -> Taa_base s0) + | Taaf_step (s10, s20, s3, taa) -> + (fun _ -> + taa_append_taa s s10 s20 s3 taa (Taa_step (s20, s3, s3, (Taa_base + s3)))) + | Taaf_step_jump (s10, s20, s3, taa) -> + (fun _ -> assert false (* absurd case *))) __ + +(** val taaf_append_tal : + abstract_status -> __ -> trace_ends_with_ret -> __ -> __ -> + trace_any_any_free -> trace_any_label -> trace_any_label **) +let taaf_append_tal s st1 fl st2 st3 taaf = + taa_append_tal s st1 fl st2 st3 (taaf_to_taa s st1 st2 taaf) + +(** val taaf_append_taa : + abstract_status -> __ -> __ -> __ -> trace_any_any_free -> trace_any_any + -> trace_any_any **) +let taaf_append_taa s st1 st2 st3 taaf = + taa_append_taa s st1 st2 st3 (taaf_to_taa s st1 st2 taaf) + +(** val taaf_cons : + abstract_status -> __ -> __ -> __ -> trace_any_any_free -> + trace_any_any_free **) +let taaf_cons s s1 s2 s3 tl = + (match tl with + | Taaf_base s20 -> (fun _ _ -> Taaf_step (s1, s1, s20, (Taa_base s1))) + | Taaf_step (s20, s30, s4, taa) -> + (fun _ _ -> Taaf_step (s1, s30, s4, (Taa_step (s1, s20, s30, taa)))) + | Taaf_step_jump (s20, s30, s4, taa) -> + (fun _ _ -> Taaf_step_jump (s1, s30, s4, (Taa_step (s1, s20, s30, + taa))))) __ __ + +(** val taaf_append_taaf : + abstract_status -> __ -> __ -> __ -> trace_any_any_free -> + trace_any_any_free -> trace_any_any_free **) +let taaf_append_taaf s st1 st2 st3 taaf1 taaf2 = + (match taaf2 with + | Taaf_base s1 -> (fun taaf10 _ -> taaf10) + | Taaf_step (s1, s2, s3, taa) -> + (fun taaf10 _ -> Taaf_step (st1, s2, s3, + (taaf_append_taa s st1 s1 s2 taaf10 taa))) + | Taaf_step_jump (s2, s3, s4, taa) -> + (fun taaf10 _ -> Taaf_step_jump (st1, s3, s4, + (taaf_append_taa s st1 s2 s3 taaf10 taa)))) taaf1 __ + diff --git a/extracted/structuredTraces.mli b/extracted/structuredTraces.mli new file mode 100644 index 0000000..431a59e --- /dev/null +++ b/extracted/structuredTraces.mli @@ -0,0 +1,979 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Relations + +open Bool + +open Jmeq + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Russell + +open Util + +open List + +open Lists + +open Nat + +open Positive + +open Types + +open Identifiers + +open CostLabel + +open Sets + +open Listb + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +open Coqlib + +open Values + +open Events + +open IOMonad + +open IO + +open Hide + +type status_class = +| Cl_return +| Cl_jump +| Cl_call +| Cl_tailcall +| Cl_other + +val status_class_rect_Type4 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 + +val status_class_rect_Type5 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 + +val status_class_rect_Type3 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 + +val status_class_rect_Type2 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 + +val status_class_rect_Type1 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 + +val status_class_rect_Type0 : + 'a1 -> 'a1 -> 'a1 -> 'a1 -> 'a1 -> status_class -> 'a1 + +val status_class_inv_rect_Type4 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val status_class_inv_rect_Type3 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val status_class_inv_rect_Type2 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val status_class_inv_rect_Type1 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val status_class_inv_rect_Type0 : + status_class -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + (__ -> 'a1) -> 'a1 + +val status_class_discr : status_class -> status_class -> __ + +val status_class_jmdiscr : status_class -> status_class -> __ + +type abstract_status = { as_pc : Deqsets.deqSet; as_pc_of : (__ -> __); + as_classify : (__ -> status_class); + as_label_of_pc : (__ -> CostLabel.costlabel + Types.option); + as_result : (__ -> Integers.int Types.option); + as_call_ident : (__ Types.sig0 -> AST.ident); + as_tailcall_ident : (__ Types.sig0 -> AST.ident) } + +val abstract_status_rect_Type4 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ -> + CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 + +val abstract_status_rect_Type5 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ -> + CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 + +val abstract_status_rect_Type3 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ -> + CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 + +val abstract_status_rect_Type2 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ -> + CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 + +val abstract_status_rect_Type1 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ -> + CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 + +val abstract_status_rect_Type0 : + (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> status_class) -> (__ -> + CostLabel.costlabel Types.option) -> __ -> (__ -> Integers.int + Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ Types.sig0 -> + AST.ident) -> 'a1) -> abstract_status -> 'a1 + +type as_status + +val as_pc : abstract_status -> Deqsets.deqSet + +val as_pc_of : abstract_status -> __ -> __ + +val as_classify : abstract_status -> __ -> status_class + +val as_label_of_pc : + abstract_status -> __ -> CostLabel.costlabel Types.option + +val as_result : abstract_status -> __ -> Integers.int Types.option + +val as_call_ident : abstract_status -> __ Types.sig0 -> AST.ident + +val as_tailcall_ident : abstract_status -> __ Types.sig0 -> AST.ident + +val abstract_status_inv_rect_Type4 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 + +val abstract_status_inv_rect_Type3 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 + +val abstract_status_inv_rect_Type2 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 + +val abstract_status_inv_rect_Type1 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 + +val abstract_status_inv_rect_Type0 : + abstract_status -> (__ -> __ -> Deqsets.deqSet -> (__ -> __) -> (__ -> + status_class) -> (__ -> CostLabel.costlabel Types.option) -> __ -> (__ -> + Integers.int Types.option) -> (__ Types.sig0 -> AST.ident) -> (__ + Types.sig0 -> AST.ident) -> __ -> 'a1) -> 'a1 + +val abstract_status_jmdiscr : abstract_status -> abstract_status -> __ + +val as_label : abstract_status -> __ -> CostLabel.costlabel Types.option + +val as_costed_exc : abstract_status -> __ -> (__, __) Types.sum + +type as_cost_label = CostLabel.costlabel Types.sig0 + +type as_cost_labels = as_cost_label List.list + +val as_cost_get_label : + abstract_status -> as_cost_label -> CostLabel.costlabel + +type as_cost_map = as_cost_label -> Nat.nat + +val as_label_safe : abstract_status -> __ Types.sig0 -> as_cost_label + +val lift_sigma_map_id : + 'a2 -> ('a1 -> (__, __) Types.sum) -> ('a1 Types.sig0 -> 'a2) -> 'a1 + Types.sig0 -> 'a2 + +val lift_cost_map_id : + abstract_status -> abstract_status -> (CostLabel.costlabel -> (__, __) + Types.sum) -> as_cost_map -> as_cost_map + +type trace_ends_with_ret = +| Ends_with_ret +| Doesnt_end_with_ret + +val trace_ends_with_ret_rect_Type4 : 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 + +val trace_ends_with_ret_rect_Type5 : 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 + +val trace_ends_with_ret_rect_Type3 : 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 + +val trace_ends_with_ret_rect_Type2 : 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 + +val trace_ends_with_ret_rect_Type1 : 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 + +val trace_ends_with_ret_rect_Type0 : 'a1 -> 'a1 -> trace_ends_with_ret -> 'a1 + +val trace_ends_with_ret_inv_rect_Type4 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val trace_ends_with_ret_inv_rect_Type3 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val trace_ends_with_ret_inv_rect_Type2 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val trace_ends_with_ret_inv_rect_Type1 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val trace_ends_with_ret_inv_rect_Type0 : + trace_ends_with_ret -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val trace_ends_with_ret_discr : + trace_ends_with_ret -> trace_ends_with_ret -> __ + +val trace_ends_with_ret_jmdiscr : + trace_ends_with_ret -> trace_ends_with_ret -> __ + +type trace_label_return = +| Tlr_base of __ * __ * trace_label_label +| Tlr_step of __ * __ * __ * trace_label_label * trace_label_return +and trace_label_label = +| Tll_base of trace_ends_with_ret * __ * __ * trace_any_label +and trace_any_label = +| Tal_base_not_return of __ * __ +| Tal_base_return of __ * __ +| Tal_base_call of __ * __ * __ * trace_label_return +| Tal_base_tailcall of __ * __ * __ * trace_label_return +| Tal_step_call of trace_ends_with_ret * __ * __ * __ * __ + * trace_label_return * trace_any_label +| Tal_step_default of trace_ends_with_ret * __ * __ * __ * trace_any_label + +val trace_label_return_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_return_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_return_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_return_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_return_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_label_return -> (__ -> __ -> + trace_label_label -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> + trace_label_label -> trace_label_return -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_label_inv_rect_Type4 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_label_label_inv_rect_Type3 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_label_label_inv_rect_Type2 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_label_label_inv_rect_Type1 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_label_label_inv_rect_Type0 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + (trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_any_label_inv_rect_Type4 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> + __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> 'a1) -> + (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> 'a1) + -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label -> __ -> + __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_label_inv_rect_Type3 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> + __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> 'a1) -> + (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> 'a1) + -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label -> __ -> + __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_label_inv_rect_Type2 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> + __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> 'a1) -> + (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> 'a1) + -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label -> __ -> + __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_label_inv_rect_Type1 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> + __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> 'a1) -> + (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> 'a1) + -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label -> __ -> + __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_label_inv_rect_Type0 : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + (__ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> + __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> + __ -> trace_label_return -> __ -> __ -> __ -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> __ -> __ -> trace_label_return -> __ -> __ -> __ -> __ -> 'a1) -> + (trace_ends_with_ret -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> + trace_label_return -> __ -> trace_any_label -> __ -> __ -> __ -> __ -> 'a1) + -> (trace_ends_with_ret -> __ -> __ -> __ -> __ -> trace_any_label -> __ -> + __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_return_discr : + abstract_status -> __ -> __ -> trace_label_return -> trace_label_return -> + __ + +val trace_label_label_discr : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + trace_label_label -> __ + +val trace_label_return_jmdiscr : + abstract_status -> __ -> __ -> trace_label_return -> trace_label_return -> + __ + +val trace_label_label_jmdiscr : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + trace_label_label -> __ + +val trace_any_label_jmdiscr : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + trace_any_label -> __ + +val tal_pc_list : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> __ + List.list + +val as_trace_any_label_length' : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + Nat.nat + +val tll_hd_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + CostLabel.costlabel + +val tlr_hd_label : + abstract_status -> __ -> __ -> trace_label_return -> CostLabel.costlabel + +type trace_any_call = +| Tac_base of __ +| Tac_step_call of __ * __ * __ * __ * trace_label_return * trace_any_call +| Tac_step_default of __ * __ * __ * trace_any_call + +val trace_any_call_rect_Type4 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> __ + -> trace_any_call -> 'a1 + +val trace_any_call_rect_Type3 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> __ + -> trace_any_call -> 'a1 + +val trace_any_call_rect_Type2 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> __ + -> trace_any_call -> 'a1 + +val trace_any_call_rect_Type1 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> __ + -> trace_any_call -> 'a1 + +val trace_any_call_rect_Type0 : + abstract_status -> (__ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ + -> __ -> trace_label_return -> __ -> trace_any_call -> 'a1 -> 'a1) -> (__ + -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> 'a1 -> 'a1) -> __ -> __ + -> trace_any_call -> 'a1 + +val trace_any_call_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> trace_label_return + -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_call_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> trace_label_return + -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_call_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> trace_label_return + -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_call_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> trace_label_return + -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_call_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_any_call -> (__ -> __ -> __ -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> __ -> trace_label_return + -> __ -> trace_any_call -> (__ -> __ -> __ -> 'a1) -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> trace_any_call -> __ -> __ -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_call_jmdiscr : + abstract_status -> __ -> __ -> trace_any_call -> trace_any_call -> __ + +type trace_label_call = +| Tlc_base of __ * __ * trace_any_call + +val trace_label_call_rect_Type4 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ -> + trace_label_call -> 'a1 + +val trace_label_call_rect_Type5 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ -> + trace_label_call -> 'a1 + +val trace_label_call_rect_Type3 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ -> + trace_label_call -> 'a1 + +val trace_label_call_rect_Type2 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ -> + trace_label_call -> 'a1 + +val trace_label_call_rect_Type1 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ -> + trace_label_call -> 'a1 + +val trace_label_call_rect_Type0 : + abstract_status -> (__ -> __ -> trace_any_call -> __ -> 'a1) -> __ -> __ -> + trace_label_call -> 'a1 + +val trace_label_call_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_call_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_call_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_call_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_call_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_label_call -> (__ -> __ -> + trace_any_call -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_label_call_discr : + abstract_status -> __ -> __ -> trace_label_call -> trace_label_call -> __ + +val trace_label_call_jmdiscr : + abstract_status -> __ -> __ -> trace_label_call -> trace_label_call -> __ + +val tlc_hd_label : + abstract_status -> __ -> __ -> trace_label_call -> CostLabel.costlabel + +type trace_label_diverges = __trace_label_diverges Lazy.t +and __trace_label_diverges = +| Tld_step of __ * __ * trace_label_label * trace_label_diverges +| Tld_base of __ * __ * __ * trace_label_call * trace_label_diverges + +val trace_label_diverges_inv_rect_Type4 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> __ + -> 'a1) -> 'a1 + +val trace_label_diverges_inv_rect_Type3 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> __ + -> 'a1) -> 'a1 + +val trace_label_diverges_inv_rect_Type2 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> __ + -> 'a1) -> 'a1 + +val trace_label_diverges_inv_rect_Type1 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> __ + -> 'a1) -> 'a1 + +val trace_label_diverges_inv_rect_Type0 : + abstract_status -> __ -> trace_label_diverges -> (__ -> __ -> + trace_label_label -> trace_label_diverges -> __ -> __ -> 'a1) -> (__ -> __ + -> __ -> trace_label_call -> __ -> __ -> trace_label_diverges -> __ -> __ + -> 'a1) -> 'a1 + +val trace_label_diverges_jmdiscr : + abstract_status -> __ -> trace_label_diverges -> trace_label_diverges -> __ + +val tld_hd_label : + abstract_status -> __ -> trace_label_diverges -> CostLabel.costlabel + +type trace_whole_program = +| Twp_terminating of __ * __ * __ * trace_label_return +| Twp_diverges of __ * __ * trace_label_diverges + +val trace_whole_program_rect_Type4 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ + -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ -> + trace_whole_program -> 'a1 + +val trace_whole_program_rect_Type5 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ + -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ -> + trace_whole_program -> 'a1 + +val trace_whole_program_rect_Type3 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ + -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ -> + trace_whole_program -> 'a1 + +val trace_whole_program_rect_Type2 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ + -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ -> + trace_whole_program -> 'a1 + +val trace_whole_program_rect_Type1 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ + -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ -> + trace_whole_program -> 'a1 + +val trace_whole_program_rect_Type0 : + abstract_status -> (__ -> __ -> __ -> __ -> __ -> trace_label_return -> __ + -> 'a1) -> (__ -> __ -> __ -> __ -> trace_label_diverges -> 'a1) -> __ -> + trace_whole_program -> 'a1 + +val trace_whole_program_inv_rect_Type4 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 + +val trace_whole_program_inv_rect_Type3 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 + +val trace_whole_program_inv_rect_Type2 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 + +val trace_whole_program_inv_rect_Type1 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 + +val trace_whole_program_inv_rect_Type0 : + abstract_status -> __ -> trace_whole_program -> (__ -> __ -> __ -> __ -> __ + -> trace_label_return -> __ -> __ -> __ -> 'a1) -> (__ -> __ -> __ -> __ -> + trace_label_diverges -> __ -> __ -> 'a1) -> 'a1 + +val trace_whole_program_jmdiscr : + abstract_status -> __ -> trace_whole_program -> trace_whole_program -> __ + +val tal_tl_label : + abstract_status -> __ -> __ -> trace_any_label -> CostLabel.costlabel + +val tll_tl_label : + abstract_status -> __ -> __ -> trace_label_label -> CostLabel.costlabel + +type trace_any_any = +| Taa_base of __ +| Taa_step of __ * __ * __ * trace_any_any + +val trace_any_any_rect_Type4 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 + +val trace_any_any_rect_Type3 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 + +val trace_any_any_rect_Type2 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 + +val trace_any_any_rect_Type1 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 + +val trace_any_any_rect_Type0 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> + trace_any_any -> 'a1 -> 'a1) -> __ -> __ -> trace_any_any -> 'a1 + +val trace_any_any_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_any_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_any_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_any_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_any_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_any_any -> (__ -> __ -> __ -> __ -> + 'a1) -> (__ -> __ -> __ -> __ -> __ -> __ -> trace_any_any -> (__ -> __ -> + __ -> 'a1) -> __ -> __ -> __ -> 'a1) -> 'a1 + +val trace_any_any_jmdiscr : + abstract_status -> __ -> __ -> trace_any_any -> trace_any_any -> __ + +val taa_non_empty : abstract_status -> __ -> __ -> trace_any_any -> Bool.bool + +val dpi1__o__taa_to_bool__o__inject : + abstract_status -> __ -> __ -> (trace_any_any, 'a1) Types.dPair -> + Bool.bool Types.sig0 + +val dpi1__o__taa_to_bool__o__bool_to_Prop__o__inject : + abstract_status -> __ -> __ -> (trace_any_any, 'a1) Types.dPair -> __ + Types.sig0 + +val eject__o__taa_to_bool__o__inject : + abstract_status -> __ -> __ -> trace_any_any Types.sig0 -> Bool.bool + Types.sig0 + +val eject__o__taa_to_bool__o__bool_to_Prop__o__inject : + abstract_status -> __ -> __ -> trace_any_any Types.sig0 -> __ Types.sig0 + +val taa_to_bool__o__bool_to_Prop__o__inject : + abstract_status -> __ -> __ -> trace_any_any -> __ Types.sig0 + +val taa_to_bool__o__inject : + abstract_status -> __ -> __ -> trace_any_any -> Bool.bool Types.sig0 + +val dpi1__o__taa_to_bool : + abstract_status -> __ -> __ -> (trace_any_any, 'a1) Types.dPair -> + Bool.bool + +val eject__o__taa_to_bool : + abstract_status -> __ -> __ -> trace_any_any Types.sig0 -> Bool.bool + +val taa_append_tal : + abstract_status -> __ -> trace_ends_with_ret -> __ -> __ -> trace_any_any + -> trace_any_label -> trace_any_label + +type intensional_event = +| IEVcost of CostLabel.costlabel +| IEVcall of AST.ident +| IEVtailcall of AST.ident * AST.ident +| IEVret of AST.ident + +val intensional_event_rect_Type4 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 + +val intensional_event_rect_Type5 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 + +val intensional_event_rect_Type3 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 + +val intensional_event_rect_Type2 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 + +val intensional_event_rect_Type1 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 + +val intensional_event_rect_Type0 : + (CostLabel.costlabel -> 'a1) -> (AST.ident -> 'a1) -> (AST.ident -> + AST.ident -> 'a1) -> (AST.ident -> 'a1) -> intensional_event -> 'a1 + +val intensional_event_inv_rect_Type4 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> + 'a1) -> 'a1 + +val intensional_event_inv_rect_Type3 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> + 'a1) -> 'a1 + +val intensional_event_inv_rect_Type2 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> + 'a1) -> 'a1 + +val intensional_event_inv_rect_Type1 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> + 'a1) -> 'a1 + +val intensional_event_inv_rect_Type0 : + intensional_event -> (CostLabel.costlabel -> __ -> 'a1) -> (AST.ident -> __ + -> 'a1) -> (AST.ident -> AST.ident -> __ -> 'a1) -> (AST.ident -> __ -> + 'a1) -> 'a1 + +val intensional_event_discr : intensional_event -> intensional_event -> __ + +val intensional_event_jmdiscr : intensional_event -> intensional_event -> __ + +type as_trace = intensional_event List.list Types.sig0 + +val cons_safe : + 'a1 Types.sig0 -> 'a1 List.list Types.sig0 -> 'a1 List.list Types.sig0 + +val append_safe : + 'a1 List.list Types.sig0 -> 'a1 List.list Types.sig0 -> 'a1 List.list + Types.sig0 + +val nil_safe : 'a1 List.list Types.sig0 + +val emittable_cost : + abstract_status -> as_cost_label -> intensional_event Types.sig0 + +val observables_trace_label_return : + abstract_status -> __ -> __ -> trace_label_return -> AST.ident -> as_trace + +val observables_trace_any_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + AST.ident -> as_trace + +val observables_trace_label_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + AST.ident -> as_trace + +val filter_map : ('a1 -> 'a2 Types.option) -> 'a1 List.list -> 'a2 List.list + +val list_distribute_sig_aux : 'a1 List.list -> 'a1 Types.sig0 List.list + +val list_distribute_sig : + 'a1 List.list Types.sig0 -> 'a1 Types.sig0 List.list + +val list_factor_sig : 'a1 Types.sig0 List.list -> 'a1 List.list Types.sig0 + +val costlabels_of_observables : + abstract_status -> as_trace -> as_cost_label List.list + +val flatten_trace_label_return : + abstract_status -> __ -> __ -> trace_label_return -> as_cost_label + List.list + +val flatten_trace_label_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_label_label -> + as_cost_label List.list + +val flatten_trace_any_label : + abstract_status -> trace_ends_with_ret -> __ -> __ -> trace_any_label -> + as_cost_label List.list + +type trace_any_any_free = +| Taaf_base of __ +| Taaf_step of __ * __ * __ * trace_any_any +| Taaf_step_jump of __ * __ * __ * trace_any_any + +val trace_any_any_free_rect_Type4 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> 'a1) -> + __ -> __ -> trace_any_any_free -> 'a1 + +val trace_any_any_free_rect_Type5 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> 'a1) -> + __ -> __ -> trace_any_any_free -> 'a1 + +val trace_any_any_free_rect_Type3 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> 'a1) -> + __ -> __ -> trace_any_any_free -> 'a1 + +val trace_any_any_free_rect_Type2 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> 'a1) -> + __ -> __ -> trace_any_any_free -> 'a1 + +val trace_any_any_free_rect_Type1 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> 'a1) -> + __ -> __ -> trace_any_any_free -> 'a1 + +val trace_any_any_free_rect_Type0 : + abstract_status -> (__ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> + __ -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> 'a1) -> + __ -> __ -> trace_any_any_free -> 'a1 + +val trace_any_any_free_inv_rect_Type4 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_any_any_free_inv_rect_Type3 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_any_any_free_inv_rect_Type2 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_any_any_free_inv_rect_Type1 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_any_any_free_inv_rect_Type0 : + abstract_status -> __ -> __ -> trace_any_any_free -> (__ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> 'a1) -> (__ -> __ -> __ -> trace_any_any -> __ -> __ -> __ -> __ -> __ + -> __ -> 'a1) -> 'a1 + +val trace_any_any_free_jmdiscr : + abstract_status -> __ -> __ -> trace_any_any_free -> trace_any_any_free -> + __ + +val taaf_non_empty : + abstract_status -> __ -> __ -> trace_any_any_free -> Bool.bool + +val taa_append_taa : + abstract_status -> __ -> __ -> __ -> trace_any_any -> trace_any_any -> + trace_any_any + +val taaf_to_taa : + abstract_status -> __ -> __ -> trace_any_any_free -> trace_any_any + +val taaf_append_tal : + abstract_status -> __ -> trace_ends_with_ret -> __ -> __ -> + trace_any_any_free -> trace_any_label -> trace_any_label + +val taaf_append_taa : + abstract_status -> __ -> __ -> __ -> trace_any_any_free -> trace_any_any -> + trace_any_any + +val taaf_cons : + abstract_status -> __ -> __ -> __ -> trace_any_any_free -> + trace_any_any_free + +val taaf_append_taaf : + abstract_status -> __ -> __ -> __ -> trace_any_any_free -> + trace_any_any_free -> trace_any_any_free + diff --git a/extracted/switchRemoval.ml b/extracted/switchRemoval.ml new file mode 100644 index 0000000..3a873f7 --- /dev/null +++ b/extracted/switchRemoval.ml @@ -0,0 +1,577 @@ +open Preamble + +open Deqsets + +open Sets + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Listb + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open Coqlib + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Csyntax + +open Fresh + +open CexecInd + +open SmallstepExec + +open Cexec + +open IO + +open IOMonad + +open Star + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open TypeComparison + +open Frontend_misc + +open MemProperties + +open MemoryInjections + +(** val convert_break_to_goto : + Csyntax.statement -> Csyntax.label -> Csyntax.statement **) +let rec convert_break_to_goto st lab = + match st with + | Csyntax.Sskip -> st + | Csyntax.Sassign (x, x0) -> st + | Csyntax.Scall (x, x0, x1) -> st + | Csyntax.Ssequence (s1, s2) -> + Csyntax.Ssequence ((convert_break_to_goto s1 lab), + (convert_break_to_goto s2 lab)) + | Csyntax.Sifthenelse (e, iftrue, iffalse) -> + Csyntax.Sifthenelse (e, (convert_break_to_goto iftrue lab), + (convert_break_to_goto iffalse lab)) + | Csyntax.Swhile (x, x0) -> st + | Csyntax.Sdowhile (x, x0) -> st + | Csyntax.Sfor (init, e, update, body) -> + Csyntax.Sfor ((convert_break_to_goto init lab), e, update, body) + | Csyntax.Sbreak -> Csyntax.Sgoto lab + | Csyntax.Scontinue -> st + | Csyntax.Sreturn x -> st + | Csyntax.Sswitch (x, x0) -> st + | Csyntax.Slabel (l, body) -> + Csyntax.Slabel (l, (convert_break_to_goto body lab)) + | Csyntax.Sgoto x -> st + | Csyntax.Scost (cost, body) -> + Csyntax.Scost (cost, (convert_break_to_goto body lab)) + +(** val produce_cond : + Csyntax.expr -> Csyntax.labeled_statements -> Identifiers.universe -> + Csyntax.label -> ((Csyntax.statement, Csyntax.label) Types.prod, + Identifiers.universe) Types.prod **) +let rec produce_cond e switch_cases u exit = + match switch_cases with + | Csyntax.LSdefault st -> + let { Types.fst = lab; Types.snd = u1 } = + Identifiers.fresh PreIdentifiers.SymbolTag u + in + let st' = convert_break_to_goto st exit in + { Types.fst = { Types.fst = (Csyntax.Slabel (lab, st')); Types.snd = + lab }; Types.snd = u1 } + | Csyntax.LScase (sz, tag, st, other_cases) -> + let { Types.fst = eta2108; Types.snd = u1 } = + produce_cond e other_cases u exit + in + let { Types.fst = sub_statements; Types.snd = sub_label } = eta2108 in + let st' = convert_break_to_goto st exit in + let { Types.fst = lab; Types.snd = u2 } = + Identifiers.fresh PreIdentifiers.SymbolTag u1 + in + let test = Csyntax.Expr ((Csyntax.Ebinop (Csyntax.Oeq, e, (Csyntax.Expr + ((Csyntax.Econst_int (sz, tag)), (Csyntax.typeof e))))), (Csyntax.Tint + (AST.I32, AST.Signed))) + in + let case_statement = Csyntax.Sifthenelse (test, (Csyntax.Slabel (lab, + (Csyntax.Ssequence (st', (Csyntax.Sgoto sub_label))))), Csyntax.Sskip) + in + { Types.fst = { Types.fst = (Csyntax.Ssequence (case_statement, + sub_statements)); Types.snd = lab }; Types.snd = u2 } + +(** val simplify_switch : + Csyntax.expr -> Csyntax.labeled_statements -> Identifiers.universe -> + (Csyntax.statement, Identifiers.universe) Types.prod **) +let simplify_switch e switch_cases uv = + let { Types.fst = exit_label; Types.snd = uv1 } = + Identifiers.fresh PreIdentifiers.SymbolTag uv + in + let { Types.fst = eta2109; Types.snd = uv2 } = + produce_cond e switch_cases uv1 exit_label + in + let { Types.fst = result; Types.snd = useless_label } = eta2109 in + { Types.fst = (Csyntax.Ssequence (result, (Csyntax.Slabel (exit_label, + Csyntax.Sskip)))); Types.snd = uv2 } + +(** val switch_removal : + Csyntax.statement -> Identifiers.universe -> ((Csyntax.statement, + (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod **) +let rec switch_removal st u = + match st with + | Csyntax.Sskip -> + { Types.fst = { Types.fst = st; Types.snd = List.Nil }; Types.snd = u } + | Csyntax.Sassign (x, x0) -> + { Types.fst = { Types.fst = st; Types.snd = List.Nil }; Types.snd = u } + | Csyntax.Scall (x, x0, x1) -> + { Types.fst = { Types.fst = st; Types.snd = List.Nil }; Types.snd = u } + | Csyntax.Ssequence (s1, s2) -> + let { Types.fst = eta2123; Types.snd = u' } = switch_removal s1 u in + let { Types.fst = s1'; Types.snd = acc1 } = eta2123 in + let { Types.fst = eta2122; Types.snd = u'' } = switch_removal s2 u' in + let { Types.fst = s2'; Types.snd = acc2 } = eta2122 in + { Types.fst = { Types.fst = (Csyntax.Ssequence (s1', s2')); Types.snd = + (List.append acc1 acc2) }; Types.snd = u'' } + | Csyntax.Sifthenelse (e, s1, s2) -> + let { Types.fst = eta2125; Types.snd = u' } = switch_removal s1 u in + let { Types.fst = s1'; Types.snd = acc1 } = eta2125 in + let { Types.fst = eta2124; Types.snd = u'' } = switch_removal s2 u' in + let { Types.fst = s2'; Types.snd = acc2 } = eta2124 in + { Types.fst = { Types.fst = (Csyntax.Sifthenelse (e, s1', s2')); + Types.snd = (List.append acc1 acc2) }; Types.snd = u'' } + | Csyntax.Swhile (e, body) -> + let { Types.fst = eta2126; Types.snd = u' } = switch_removal body u in + let { Types.fst = body'; Types.snd = acc } = eta2126 in + { Types.fst = { Types.fst = (Csyntax.Swhile (e, body')); Types.snd = + acc }; Types.snd = u' } + | Csyntax.Sdowhile (e, body) -> + let { Types.fst = eta2127; Types.snd = u' } = switch_removal body u in + let { Types.fst = body'; Types.snd = acc } = eta2127 in + { Types.fst = { Types.fst = (Csyntax.Sdowhile (e, body')); Types.snd = + acc }; Types.snd = u' } + | Csyntax.Sfor (s1, e, s2, s3) -> + let { Types.fst = eta2130; Types.snd = u' } = switch_removal s1 u in + let { Types.fst = s1'; Types.snd = acc1 } = eta2130 in + let { Types.fst = eta2129; Types.snd = u'' } = switch_removal s2 u' in + let { Types.fst = s2'; Types.snd = acc2 } = eta2129 in + let { Types.fst = eta2128; Types.snd = u''' } = switch_removal s3 u'' in + let { Types.fst = s3'; Types.snd = acc3 } = eta2128 in + { Types.fst = { Types.fst = (Csyntax.Sfor (s1', e, s2', s3')); + Types.snd = (List.append acc1 (List.append acc2 acc3)) }; Types.snd = + u''' } + | Csyntax.Sbreak -> + { Types.fst = { Types.fst = st; Types.snd = List.Nil }; Types.snd = u } + | Csyntax.Scontinue -> + { Types.fst = { Types.fst = st; Types.snd = List.Nil }; Types.snd = u } + | Csyntax.Sreturn x -> + { Types.fst = { Types.fst = st; Types.snd = List.Nil }; Types.snd = u } + | Csyntax.Sswitch (e, branches) -> + let { Types.fst = eta2131; Types.snd = u' } = + switch_removal_branches branches u + in + let { Types.fst = sf_branches; Types.snd = acc } = eta2131 in + let { Types.fst = switch_tmp; Types.snd = u'' } = + Identifiers.fresh PreIdentifiers.SymbolTag u' + in + let ident = Csyntax.Expr ((Csyntax.Evar switch_tmp), (Csyntax.typeof e)) + in + let assign = Csyntax.Sassign (ident, e) in + let { Types.fst = result; Types.snd = u''' } = + simplify_switch ident sf_branches u'' + in + { Types.fst = { Types.fst = (Csyntax.Ssequence (assign, result)); + Types.snd = (List.Cons ({ Types.fst = switch_tmp; Types.snd = + (Csyntax.typeof e) }, acc)) }; Types.snd = u''' } + | Csyntax.Slabel (label, body) -> + let { Types.fst = eta2132; Types.snd = u' } = switch_removal body u in + let { Types.fst = body'; Types.snd = acc } = eta2132 in + { Types.fst = { Types.fst = (Csyntax.Slabel (label, body')); Types.snd = + acc }; Types.snd = u' } + | Csyntax.Sgoto x -> + { Types.fst = { Types.fst = st; Types.snd = List.Nil }; Types.snd = u } + | Csyntax.Scost (cost, body) -> + let { Types.fst = eta2133; Types.snd = u' } = switch_removal body u in + let { Types.fst = body'; Types.snd = acc } = eta2133 in + { Types.fst = { Types.fst = (Csyntax.Scost (cost, body')); Types.snd = + acc }; Types.snd = u' } +(** val switch_removal_branches : + Csyntax.labeled_statements -> Identifiers.universe -> + ((Csyntax.labeled_statements, (AST.ident, Csyntax.type0) Types.prod + List.list) Types.prod, Identifiers.universe) Types.prod **) +and switch_removal_branches l u = + match l with + | Csyntax.LSdefault st -> + let { Types.fst = eta2134; Types.snd = u' } = switch_removal st u in + let { Types.fst = st'; Types.snd = acc1 } = eta2134 in + { Types.fst = { Types.fst = (Csyntax.LSdefault st'); Types.snd = acc1 }; + Types.snd = u' } + | Csyntax.LScase (sz, int, st, tl) -> + let { Types.fst = eta2136; Types.snd = u' } = + switch_removal_branches tl u + in + let { Types.fst = tl_result; Types.snd = acc1 } = eta2136 in + let { Types.fst = eta2135; Types.snd = u'' } = switch_removal st u' in + let { Types.fst = st'; Types.snd = acc2 } = eta2135 in + { Types.fst = { Types.fst = (Csyntax.LScase (sz, int, st', tl_result)); + Types.snd = (List.append acc1 acc2) }; Types.snd = u'' } + +(** val ret_st : + (('a1, (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod -> 'a1 **) +let ret_st x = + let { Types.fst = eta2137; Types.snd = u } = x in eta2137.Types.fst + +(** val ret_vars : + (('a1, (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod -> (AST.ident, Csyntax.type0) Types.prod + List.list **) +let ret_vars x = + let { Types.fst = eta2138; Types.snd = u } = x in eta2138.Types.snd + +(** val ret_u : + (('a1, (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod -> Identifiers.universe **) +let ret_u x = + let { Types.fst = eta2139; Types.snd = u } = x in + let { Types.fst = s; Types.snd = vars } = eta2139 in u + +(** val least_identifier : PreIdentifiers.identifier **) +let least_identifier = + Positive.One + +(** val max_of_expr : Csyntax.expr -> AST.ident **) +let rec max_of_expr = function +| Csyntax.Expr (ed, x) -> + (match ed with + | Csyntax.Econst_int (x0, x1) -> least_identifier + | Csyntax.Evar id -> id + | Csyntax.Ederef e1 -> max_of_expr e1 + | Csyntax.Eaddrof e1 -> max_of_expr e1 + | Csyntax.Eunop (x0, e1) -> max_of_expr e1 + | Csyntax.Ebinop (x0, e1, e2) -> + Fresh.max_id (max_of_expr e1) (max_of_expr e2) + | Csyntax.Ecast (x0, e1) -> max_of_expr e1 + | Csyntax.Econdition (e1, e2, e3) -> + Fresh.max_id (max_of_expr e1) + (Fresh.max_id (max_of_expr e2) (max_of_expr e3)) + | Csyntax.Eandbool (e1, e2) -> + Fresh.max_id (max_of_expr e1) (max_of_expr e2) + | Csyntax.Eorbool (e1, e2) -> + Fresh.max_id (max_of_expr e1) (max_of_expr e2) + | Csyntax.Esizeof x0 -> least_identifier + | Csyntax.Efield (r, f) -> Fresh.max_id f (max_of_expr r) + | Csyntax.Ecost (x0, e1) -> max_of_expr e1) + +(** val max_of_statement : Csyntax.statement -> AST.ident **) +let rec max_of_statement = function +| Csyntax.Sskip -> least_identifier +| Csyntax.Sassign (e1, e2) -> Fresh.max_id (max_of_expr e1) (max_of_expr e2) +| Csyntax.Scall (r, f, args) -> + let retmax = + match r with + | Types.None -> least_identifier + | Types.Some e -> max_of_expr e + in + Fresh.max_id (max_of_expr f) + (Fresh.max_id retmax + (List.foldr (fun elt acc -> Fresh.max_id (max_of_expr elt) acc) + least_identifier args)) +| Csyntax.Ssequence (s1, s2) -> + Fresh.max_id (max_of_statement s1) (max_of_statement s2) +| Csyntax.Sifthenelse (e, s1, s2) -> + Fresh.max_id (max_of_expr e) + (Fresh.max_id (max_of_statement s1) (max_of_statement s2)) +| Csyntax.Swhile (e, body) -> + Fresh.max_id (max_of_expr e) (max_of_statement body) +| Csyntax.Sdowhile (e, body) -> + Fresh.max_id (max_of_expr e) (max_of_statement body) +| Csyntax.Sfor (init, test, incr, body) -> + Fresh.max_id (Fresh.max_id (max_of_statement init) (max_of_expr test)) + (Fresh.max_id (max_of_statement incr) (max_of_statement body)) +| Csyntax.Sbreak -> least_identifier +| Csyntax.Scontinue -> least_identifier +| Csyntax.Sreturn opt -> + (match opt with + | Types.None -> least_identifier + | Types.Some e -> max_of_expr e) +| Csyntax.Sswitch (e, ls) -> Fresh.max_id (max_of_expr e) (max_of_ls ls) +| Csyntax.Slabel (lab, body) -> Fresh.max_id lab (max_of_statement body) +| Csyntax.Sgoto lab -> lab +| Csyntax.Scost (x, body) -> max_of_statement body +(** val max_of_ls : Csyntax.labeled_statements -> AST.ident **) +and max_of_ls = function +| Csyntax.LSdefault s -> max_of_statement s +| Csyntax.LScase (x, x0, s, ls') -> + Fresh.max_id (max_of_ls ls') (max_of_statement s) + +(** val max_id_of_function : Csyntax.function0 -> AST.ident **) +let max_id_of_function f = + Fresh.max_id (max_of_statement f.Csyntax.fn_body) (Fresh.max_id_of_fn f) + +(** val function_switch_removal : + Csyntax.function0 -> (Csyntax.function0, (AST.ident, Csyntax.type0) + Types.prod List.list) Types.prod **) +let function_switch_removal f = + let u = Fresh.universe_of_max (max_id_of_function f) in + let { Types.fst = eta2140; Types.snd = u' } = + switch_removal f.Csyntax.fn_body u + in + let { Types.fst = st; Types.snd = vars } = eta2140 in + let result = { Csyntax.fn_return = f.Csyntax.fn_return; Csyntax.fn_params = + f.Csyntax.fn_params; Csyntax.fn_vars = + (List.append vars f.Csyntax.fn_vars); Csyntax.fn_body = st } + in + { Types.fst = result; Types.snd = vars } + +(** val fundef_switch_removal : + Csyntax.clight_fundef -> Csyntax.clight_fundef **) +let rec fundef_switch_removal f = match f with +| Csyntax.CL_Internal f0 -> + Csyntax.CL_Internal (function_switch_removal f0).Types.fst +| Csyntax.CL_External (x, x0, x1) -> f + +(** val program_switch_removal : + Csyntax.clight_program -> Csyntax.clight_program **) +let rec program_switch_removal p = + AST.transform_program p (fun x -> fundef_switch_removal) + +(** val nonempty_block_rect_Type4 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 **) +let rec nonempty_block_rect_Type4 m b h_mk_nonempty_block = + h_mk_nonempty_block __ __ + +(** val nonempty_block_rect_Type5 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 **) +let rec nonempty_block_rect_Type5 m b h_mk_nonempty_block = + h_mk_nonempty_block __ __ + +(** val nonempty_block_rect_Type3 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 **) +let rec nonempty_block_rect_Type3 m b h_mk_nonempty_block = + h_mk_nonempty_block __ __ + +(** val nonempty_block_rect_Type2 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 **) +let rec nonempty_block_rect_Type2 m b h_mk_nonempty_block = + h_mk_nonempty_block __ __ + +(** val nonempty_block_rect_Type1 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 **) +let rec nonempty_block_rect_Type1 m b h_mk_nonempty_block = + h_mk_nonempty_block __ __ + +(** val nonempty_block_rect_Type0 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 **) +let rec nonempty_block_rect_Type0 m b h_mk_nonempty_block = + h_mk_nonempty_block __ __ + +(** val nonempty_block_inv_rect_Type4 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let nonempty_block_inv_rect_Type4 x1 x2 h1 = + let hcut = nonempty_block_rect_Type4 x1 x2 h1 in hcut __ + +(** val nonempty_block_inv_rect_Type3 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let nonempty_block_inv_rect_Type3 x1 x2 h1 = + let hcut = nonempty_block_rect_Type3 x1 x2 h1 in hcut __ + +(** val nonempty_block_inv_rect_Type2 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let nonempty_block_inv_rect_Type2 x1 x2 h1 = + let hcut = nonempty_block_rect_Type2 x1 x2 h1 in hcut __ + +(** val nonempty_block_inv_rect_Type1 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let nonempty_block_inv_rect_Type1 x1 x2 h1 = + let hcut = nonempty_block_rect_Type1 x1 x2 h1 in hcut __ + +(** val nonempty_block_inv_rect_Type0 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let nonempty_block_inv_rect_Type0 x1 x2 h1 = + let hcut = nonempty_block_rect_Type0 x1 x2 h1 in hcut __ + +(** val nonempty_block_discr : GenMem.mem -> Pointers.block -> __ **) +let nonempty_block_discr a1 a2 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __)) __ + +(** val nonempty_block_jmdiscr : GenMem.mem -> Pointers.block -> __ **) +let nonempty_block_jmdiscr a1 a2 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __)) __ + +(** val sr_memext_rect_Type4 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> 'a1) -> 'a1 **) +let rec sr_memext_rect_Type4 m1 m2 writeable h_mk_sr_memext = + h_mk_sr_memext __ __ __ + +(** val sr_memext_rect_Type5 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> 'a1) -> 'a1 **) +let rec sr_memext_rect_Type5 m1 m2 writeable h_mk_sr_memext = + h_mk_sr_memext __ __ __ + +(** val sr_memext_rect_Type3 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> 'a1) -> 'a1 **) +let rec sr_memext_rect_Type3 m1 m2 writeable h_mk_sr_memext = + h_mk_sr_memext __ __ __ + +(** val sr_memext_rect_Type2 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> 'a1) -> 'a1 **) +let rec sr_memext_rect_Type2 m1 m2 writeable h_mk_sr_memext = + h_mk_sr_memext __ __ __ + +(** val sr_memext_rect_Type1 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> 'a1) -> 'a1 **) +let rec sr_memext_rect_Type1 m1 m2 writeable h_mk_sr_memext = + h_mk_sr_memext __ __ __ + +(** val sr_memext_rect_Type0 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> 'a1) -> 'a1 **) +let rec sr_memext_rect_Type0 m1 m2 writeable h_mk_sr_memext = + h_mk_sr_memext __ __ __ + +(** val sr_memext_inv_rect_Type4 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let sr_memext_inv_rect_Type4 x1 x2 x3 h1 = + let hcut = sr_memext_rect_Type4 x1 x2 x3 h1 in hcut __ + +(** val sr_memext_inv_rect_Type3 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let sr_memext_inv_rect_Type3 x1 x2 x3 h1 = + let hcut = sr_memext_rect_Type3 x1 x2 x3 h1 in hcut __ + +(** val sr_memext_inv_rect_Type2 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let sr_memext_inv_rect_Type2 x1 x2 x3 h1 = + let hcut = sr_memext_rect_Type2 x1 x2 x3 h1 in hcut __ + +(** val sr_memext_inv_rect_Type1 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let sr_memext_inv_rect_Type1 x1 x2 x3 h1 = + let hcut = sr_memext_rect_Type1 x1 x2 x3 h1 in hcut __ + +(** val sr_memext_inv_rect_Type0 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ + -> __ -> 'a1) -> 'a1 **) +let sr_memext_inv_rect_Type0 x1 x2 x3 h1 = + let hcut = sr_memext_rect_Type0 x1 x2 x3 h1 in hcut __ + +(** val sr_memext_discr : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> __ **) +let sr_memext_discr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val sr_memext_jmdiscr : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> __ **) +let sr_memext_jmdiscr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val env_codomain : + Csem.env -> (AST.ident, Csyntax.type0) Types.prod List.list -> + Pointers.block Frontend_misc.lset **) +let env_codomain e l = + Identifiers.foldi PreIdentifiers.SymbolTag (fun id block acc -> + match Frontend_misc.mem_assoc_env id l with + | Bool.True -> List.Cons (block, acc) + | Bool.False -> acc) e List.Nil + diff --git a/extracted/switchRemoval.mli b/extracted/switchRemoval.mli new file mode 100644 index 0000000..4acfc61 --- /dev/null +++ b/extracted/switchRemoval.mli @@ -0,0 +1,278 @@ +open Preamble + +open Deqsets + +open Sets + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Listb + +open Proper + +open PositiveMap + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Lists + +open Positive + +open Identifiers + +open CostLabel + +open Coqlib + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open Csyntax + +open Fresh + +open CexecInd + +open SmallstepExec + +open Cexec + +open IO + +open IOMonad + +open Star + +open ClassifyOp + +open Events + +open Smallstep + +open Extra_bool + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Globalenvs + +open Csem + +open TypeComparison + +open Frontend_misc + +open MemProperties + +open MemoryInjections + +val convert_break_to_goto : + Csyntax.statement -> Csyntax.label -> Csyntax.statement + +val produce_cond : + Csyntax.expr -> Csyntax.labeled_statements -> Identifiers.universe -> + Csyntax.label -> ((Csyntax.statement, Csyntax.label) Types.prod, + Identifiers.universe) Types.prod + +val simplify_switch : + Csyntax.expr -> Csyntax.labeled_statements -> Identifiers.universe -> + (Csyntax.statement, Identifiers.universe) Types.prod + +val switch_removal_branches : + Csyntax.labeled_statements -> Identifiers.universe -> + ((Csyntax.labeled_statements, (AST.ident, Csyntax.type0) Types.prod + List.list) Types.prod, Identifiers.universe) Types.prod + +val switch_removal : + Csyntax.statement -> Identifiers.universe -> ((Csyntax.statement, + (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod + +val ret_st : + (('a1, (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod -> 'a1 + +val ret_vars : + (('a1, (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod -> (AST.ident, Csyntax.type0) Types.prod + List.list + +val ret_u : + (('a1, (AST.ident, Csyntax.type0) Types.prod List.list) Types.prod, + Identifiers.universe) Types.prod -> Identifiers.universe + +val least_identifier : PreIdentifiers.identifier + +val max_of_expr : Csyntax.expr -> AST.ident + +val max_of_ls : Csyntax.labeled_statements -> AST.ident + +val max_of_statement : Csyntax.statement -> AST.ident + +val max_id_of_function : Csyntax.function0 -> AST.ident + +val function_switch_removal : + Csyntax.function0 -> (Csyntax.function0, (AST.ident, Csyntax.type0) + Types.prod List.list) Types.prod + +val fundef_switch_removal : Csyntax.clight_fundef -> Csyntax.clight_fundef + +val program_switch_removal : Csyntax.clight_program -> Csyntax.clight_program + +val nonempty_block_rect_Type4 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 + +val nonempty_block_rect_Type5 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 + +val nonempty_block_rect_Type3 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 + +val nonempty_block_rect_Type2 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 + +val nonempty_block_rect_Type1 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 + +val nonempty_block_rect_Type0 : + GenMem.mem -> Pointers.block -> (__ -> __ -> 'a1) -> 'a1 + +val nonempty_block_inv_rect_Type4 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val nonempty_block_inv_rect_Type3 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val nonempty_block_inv_rect_Type2 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val nonempty_block_inv_rect_Type1 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val nonempty_block_inv_rect_Type0 : + GenMem.mem -> Pointers.block -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val nonempty_block_discr : GenMem.mem -> Pointers.block -> __ + +val nonempty_block_jmdiscr : GenMem.mem -> Pointers.block -> __ + +val sr_memext_rect_Type4 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + 'a1) -> 'a1 + +val sr_memext_rect_Type5 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + 'a1) -> 'a1 + +val sr_memext_rect_Type3 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + 'a1) -> 'a1 + +val sr_memext_rect_Type2 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + 'a1) -> 'a1 + +val sr_memext_rect_Type1 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + 'a1) -> 'a1 + +val sr_memext_rect_Type0 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + 'a1) -> 'a1 + +val sr_memext_inv_rect_Type4 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val sr_memext_inv_rect_Type3 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val sr_memext_inv_rect_Type2 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val sr_memext_inv_rect_Type1 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val sr_memext_inv_rect_Type0 : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> (__ -> __ -> __ -> + __ -> 'a1) -> 'a1 + +val sr_memext_discr : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> __ + +val sr_memext_jmdiscr : + GenMem.mem -> GenMem.mem -> Pointers.block List.list -> __ + +val env_codomain : + Csem.env -> (AST.ident, Csyntax.type0) Types.prod List.list -> + Pointers.block Frontend_misc.lset + diff --git a/extracted/toCminor.ml b/extracted/toCminor.ml new file mode 100644 index 0000000..4131f6c --- /dev/null +++ b/extracted/toCminor.ml @@ -0,0 +1,2265 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open ClassifyOp + +open Fresh + +(** val gather_mem_vars_expr : Csyntax.expr -> Identifiers.identifier_set **) +let rec gather_mem_vars_expr = function +| Csyntax.Expr (ed, ty) -> + (match ed with + | Csyntax.Econst_int (x, x0) -> + Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Evar x -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Ederef e1 -> gather_mem_vars_expr e1 + | Csyntax.Eaddrof e1 -> gather_mem_vars_addr e1 + | Csyntax.Eunop (x, e1) -> gather_mem_vars_expr e1 + | Csyntax.Ebinop (x, e1, e2) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_expr e2) + | Csyntax.Ecast (x, e1) -> gather_mem_vars_expr e1 + | Csyntax.Econdition (e1, e2, e3) -> + Identifiers.union_set PreIdentifiers.SymbolTag + (Identifiers.union_set PreIdentifiers.SymbolTag + (gather_mem_vars_expr e1) (gather_mem_vars_expr e2)) + (gather_mem_vars_expr e3) + | Csyntax.Eandbool (e1, e2) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_expr e2) + | Csyntax.Eorbool (e1, e2) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_expr e2) + | Csyntax.Esizeof x -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Efield (e1, x) -> gather_mem_vars_expr e1 + | Csyntax.Ecost (x, e1) -> gather_mem_vars_expr e1) +(** val gather_mem_vars_addr : Csyntax.expr -> Identifiers.identifier_set **) +and gather_mem_vars_addr = function +| Csyntax.Expr (ed, ty) -> + (match ed with + | Csyntax.Econst_int (x, x0) -> + Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Evar x -> + Identifiers.add_set PreIdentifiers.SymbolTag + (Identifiers.empty_set PreIdentifiers.SymbolTag) x + | Csyntax.Ederef e1 -> gather_mem_vars_expr e1 + | Csyntax.Eaddrof x -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Eunop (x, x0) -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Ebinop (x, x0, x1) -> + Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Ecast (x, x0) -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Econdition (x, x0, x1) -> + Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Eandbool (x, x0) -> + Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Eorbool (x, x0) -> + Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Esizeof x -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Csyntax.Efield (e1, x) -> gather_mem_vars_addr e1 + | Csyntax.Ecost (x, x0) -> Identifiers.empty_set PreIdentifiers.SymbolTag) + +(** val gather_mem_vars_stmt : + Csyntax.statement -> Identifiers.identifier_set **) +let rec gather_mem_vars_stmt = function +| Csyntax.Sskip -> Identifiers.empty_set PreIdentifiers.SymbolTag +| Csyntax.Sassign (e1, e2) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_expr e2) +| Csyntax.Scall (oe1, e2, es) -> + Identifiers.union_set PreIdentifiers.SymbolTag + (Identifiers.union_set PreIdentifiers.SymbolTag + (match oe1 with + | Types.None -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Types.Some e1 -> gather_mem_vars_expr e1) (gather_mem_vars_expr e2)) + (Util.foldl (fun s0 e -> + Identifiers.union_set PreIdentifiers.SymbolTag s0 + (gather_mem_vars_expr e)) + (Identifiers.empty_set PreIdentifiers.SymbolTag) es) +| Csyntax.Ssequence (s1, s2) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_stmt s1) + (gather_mem_vars_stmt s2) +| Csyntax.Sifthenelse (e1, s1, s2) -> + Identifiers.union_set PreIdentifiers.SymbolTag + (Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_stmt s1)) (gather_mem_vars_stmt s2) +| Csyntax.Swhile (e1, s1) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_stmt s1) +| Csyntax.Sdowhile (e1, s1) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_stmt s1) +| Csyntax.Sfor (s1, e1, s2, s3) -> + Identifiers.union_set PreIdentifiers.SymbolTag + (Identifiers.union_set PreIdentifiers.SymbolTag + (Identifiers.union_set PreIdentifiers.SymbolTag + (gather_mem_vars_stmt s1) (gather_mem_vars_expr e1)) + (gather_mem_vars_stmt s2)) (gather_mem_vars_stmt s3) +| Csyntax.Sbreak -> Identifiers.empty_set PreIdentifiers.SymbolTag +| Csyntax.Scontinue -> Identifiers.empty_set PreIdentifiers.SymbolTag +| Csyntax.Sreturn oe1 -> + (match oe1 with + | Types.None -> Identifiers.empty_set PreIdentifiers.SymbolTag + | Types.Some e1 -> gather_mem_vars_expr e1) +| Csyntax.Sswitch (e1, ls) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_expr e1) + (gather_mem_vars_ls ls) +| Csyntax.Slabel (x, s1) -> gather_mem_vars_stmt s1 +| Csyntax.Sgoto x -> Identifiers.empty_set PreIdentifiers.SymbolTag +| Csyntax.Scost (x, s1) -> gather_mem_vars_stmt s1 +(** val gather_mem_vars_ls : + Csyntax.labeled_statements -> Identifiers.identifier_set **) +and gather_mem_vars_ls = function +| Csyntax.LSdefault s1 -> gather_mem_vars_stmt s1 +| Csyntax.LScase (x, x0, s1, ls1) -> + Identifiers.union_set PreIdentifiers.SymbolTag (gather_mem_vars_stmt s1) + (gather_mem_vars_ls ls1) + +type var_type = +| Global of AST.region +| Stack of Nat.nat +| Local + +(** val var_type_rect_Type4 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 **) +let rec var_type_rect_Type4 h_Global h_Stack h_Local = function +| Global x_13038 -> h_Global x_13038 +| Stack x_13039 -> h_Stack x_13039 +| Local -> h_Local + +(** val var_type_rect_Type5 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 **) +let rec var_type_rect_Type5 h_Global h_Stack h_Local = function +| Global x_13044 -> h_Global x_13044 +| Stack x_13045 -> h_Stack x_13045 +| Local -> h_Local + +(** val var_type_rect_Type3 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 **) +let rec var_type_rect_Type3 h_Global h_Stack h_Local = function +| Global x_13050 -> h_Global x_13050 +| Stack x_13051 -> h_Stack x_13051 +| Local -> h_Local + +(** val var_type_rect_Type2 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 **) +let rec var_type_rect_Type2 h_Global h_Stack h_Local = function +| Global x_13056 -> h_Global x_13056 +| Stack x_13057 -> h_Stack x_13057 +| Local -> h_Local + +(** val var_type_rect_Type1 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 **) +let rec var_type_rect_Type1 h_Global h_Stack h_Local = function +| Global x_13062 -> h_Global x_13062 +| Stack x_13063 -> h_Stack x_13063 +| Local -> h_Local + +(** val var_type_rect_Type0 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 **) +let rec var_type_rect_Type0 h_Global h_Stack h_Local = function +| Global x_13068 -> h_Global x_13068 +| Stack x_13069 -> h_Stack x_13069 +| Local -> h_Local + +(** val var_type_inv_rect_Type4 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 **) +let var_type_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = var_type_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val var_type_inv_rect_Type3 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 **) +let var_type_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = var_type_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val var_type_inv_rect_Type2 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 **) +let var_type_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = var_type_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val var_type_inv_rect_Type1 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 **) +let var_type_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = var_type_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val var_type_inv_rect_Type0 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 **) +let var_type_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = var_type_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val var_type_discr : var_type -> var_type -> __ **) +let var_type_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Global a0 -> Obj.magic (fun _ dH -> dH __) + | Stack a0 -> Obj.magic (fun _ dH -> dH __) + | Local -> Obj.magic (fun _ dH -> dH)) y + +(** val var_type_jmdiscr : var_type -> var_type -> __ **) +let var_type_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Global a0 -> Obj.magic (fun _ dH -> dH __) + | Stack a0 -> Obj.magic (fun _ dH -> dH __) + | Local -> Obj.magic (fun _ dH -> dH)) y + +type var_types = + (var_type, Csyntax.type0) Types.prod Identifiers.identifier_map + +(** val lookup' : + var_types -> PreIdentifiers.identifier -> (var_type, Csyntax.type0) + Types.prod Errors.res **) +let lookup' vars id = + Errors.opt_to_res (List.Cons ((Errors.MSG + ErrorMessages.UndeclaredIdentifier), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil)))) + (Identifiers.lookup PreIdentifiers.SymbolTag vars id) + +(** val always_alloc : Csyntax.type0 -> Bool.bool **) +let always_alloc = function +| Csyntax.Tvoid -> Bool.False +| Csyntax.Tint (x, x0) -> Bool.False +| Csyntax.Tpointer x -> Bool.False +| Csyntax.Tarray (x, x0) -> Bool.True +| Csyntax.Tfunction (x, x0) -> Bool.False +| Csyntax.Tstruct (x, x0) -> Bool.True +| Csyntax.Tunion (x, x0) -> Bool.True +| Csyntax.Tcomp_ptr x -> Bool.False + +(** val characterise_vars : + ((AST.ident, AST.region) Types.prod, Csyntax.type0) Types.prod List.list + -> Csyntax.function0 -> (var_types, Nat.nat) Types.prod **) +let characterise_vars globals f = + let m = + List.foldr (fun idrt m -> + Identifiers.add PreIdentifiers.SymbolTag m idrt.Types.fst.Types.fst + { Types.fst = (Global idrt.Types.fst.Types.snd); Types.snd = + idrt.Types.snd }) (Identifiers.empty_map PreIdentifiers.SymbolTag) + globals + in + let mem_vars = gather_mem_vars_stmt f.Csyntax.fn_body in + let { Types.fst = m0; Types.snd = stacksize } = + List.foldr (fun v ms -> + let { Types.fst = m0; Types.snd = stack_high } = ms in + let { Types.fst = id; Types.snd = ty } = v in + let { Types.fst = c; Types.snd = stack_high0 } = + match Bool.orb (always_alloc ty) + (Identifiers.member PreIdentifiers.SymbolTag mem_vars id) with + | Bool.True -> + { Types.fst = (Stack stack_high); Types.snd = + (Nat.plus stack_high (Csyntax.sizeof ty)) } + | Bool.False -> { Types.fst = Local; Types.snd = stack_high } + in + { Types.fst = + (Identifiers.add PreIdentifiers.SymbolTag m0 id { Types.fst = c; + Types.snd = ty }); Types.snd = stack_high0 }) { Types.fst = m; + Types.snd = Nat.O } (List.append f.Csyntax.fn_params f.Csyntax.fn_vars) + in + { Types.fst = m0; Types.snd = stacksize } + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open FrontEndOps + +open Cminor_syntax + +(** val type_should_eq : + Csyntax.type0 -> Csyntax.type0 -> 'a1 -> 'a1 Errors.res **) +let type_should_eq ty1 ty2 p = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (TypeComparison.assert_type_eq ty1 ty2)) (fun _ -> + Obj.magic (Errors.OK ((fun p0 -> p0) p)))) + +(** val region_should_eq : + AST.region -> AST.region -> 'a1 -> 'a1 Errors.res **) +let region_should_eq clearme r2 x = + (match clearme with + | AST.XData -> + (fun clearme0 -> + match clearme0 with + | AST.XData -> (fun _ p -> Errors.OK p) + | AST.Code -> + (fun _ p -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + | AST.Code -> + (fun clearme0 -> + match clearme0 with + | AST.XData -> + (fun _ p -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | AST.Code -> (fun _ p -> Errors.OK p))) r2 __ x + +(** val typ_should_eq : AST.typ -> AST.typ -> 'a1 -> 'a1 Errors.res **) +let typ_should_eq ty1 ty2 p = + match AST.typ_eq ty1 ty2 with + | Types.Inl _ -> Errors.OK p + | Types.Inr _ -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + +(** val translate_unop : + AST.typ -> AST.typ -> Csyntax.unary_operation -> + FrontEndOps.unary_operation Errors.res **) +let translate_unop t t' = function +| Csyntax.Onotbool -> + (match t with + | AST.ASTint (sz, sg) -> + (match t' with + | AST.ASTint (sz', sg') -> + Errors.OK (FrontEndOps.Onotbool ((AST.ASTint (sz, sg)), sz', sg')) + | AST.ASTptr -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | AST.ASTptr -> + (match t' with + | AST.ASTint (sz', sg') -> + Errors.OK (FrontEndOps.Onotbool (AST.ASTptr, sz', sg')) + | AST.ASTptr -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) +| Csyntax.Onotint -> + (match t' with + | AST.ASTint (sz, sg) -> + typ_should_eq (AST.ASTint (sz, sg)) t (FrontEndOps.Onotint (sz, sg)) + | AST.ASTptr -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) +| Csyntax.Oneg -> + (match t' with + | AST.ASTint (sz, sg) -> + typ_should_eq (AST.ASTint (sz, sg)) t (FrontEndOps.Onegint (sz, sg)) + | AST.ASTptr -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + +(** val fix_ptr_type : + Csyntax.type0 -> Nat.nat Types.option -> Cminor_syntax.expr -> + Cminor_syntax.expr **) +let fix_ptr_type ty n e = + e + +(** val translate_add : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_add ty1 ty2 ty' = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_add ty1 ty2 with + | ClassifyOp.Add_case_ii (sz, sg) -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, sg)) (Csyntax.typ_of_type ty') + (Cminor_syntax.Op2 ((AST.ASTint (sz, sg)), (AST.ASTint (sz, sg)), + (AST.ASTint (sz, sg)), (FrontEndOps.Oadd (sz, sg)), e1, e2))) + | ClassifyOp.Add_case_pi (n, ty, sz, sg) -> + (fun e1 e2 -> + typ_should_eq AST.ASTptr (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 + (AST.ASTptr, (AST.ASTint (AST.I16, AST.Signed)), AST.ASTptr, + (FrontEndOps.Oaddpi AST.I16), (fix_ptr_type ty n e1), + (Cminor_syntax.Op2 ((AST.ASTint (AST.I16, AST.Signed)), (AST.ASTint + (AST.I16, AST.Signed)), (AST.ASTint (AST.I16, AST.Signed)), + (FrontEndOps.Omul (AST.I16, AST.Signed)), (Cminor_syntax.Op1 + ((AST.ASTint (sz, sg)), (AST.ASTint (AST.I16, AST.Signed)), + (FrontEndOps.Ocastint (sz, sg, AST.I16, AST.Signed)), e2)), + (Cminor_syntax.Cst ((AST.ASTint (AST.I16, AST.Signed)), + (FrontEndOps.Ointconst (AST.I16, AST.Signed, + (AST.repr AST.I16 (Csyntax.sizeof ty))))))))))) + | ClassifyOp.Add_case_ip (n, sz, sg, ty) -> + (fun e1 e2 -> + typ_should_eq AST.ASTptr (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 + ((AST.ASTint (AST.I16, AST.Signed)), AST.ASTptr, AST.ASTptr, + (FrontEndOps.Oaddip AST.I16), (Cminor_syntax.Op2 ((AST.ASTint + (AST.I16, AST.Signed)), (AST.ASTint (AST.I16, AST.Signed)), + (AST.ASTint (AST.I16, AST.Signed)), (FrontEndOps.Omul (AST.I16, + AST.Signed)), (Cminor_syntax.Op1 ((AST.ASTint (sz, sg)), (AST.ASTint + (AST.I16, AST.Signed)), (FrontEndOps.Ocastint (sz, sg, AST.I16, + AST.Signed)), e1)), (Cminor_syntax.Cst ((AST.ASTint (AST.I16, + AST.Signed)), (FrontEndOps.Ointconst (AST.I16, AST.Signed, + (AST.repr AST.I16 (Csyntax.sizeof ty)))))))), + (fix_ptr_type ty n e2)))) + | ClassifyOp.Add_default (x, x0) -> + (fun e1 e2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val translate_sub : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_sub ty1 ty2 ty' = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_sub ty1 ty2 with + | ClassifyOp.Sub_case_ii (sz, sg) -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, sg)) (Csyntax.typ_of_type ty') + (Cminor_syntax.Op2 ((AST.ASTint (sz, sg)), (AST.ASTint (sz, sg)), + (AST.ASTint (sz, sg)), (FrontEndOps.Osub (sz, sg)), e1, e2))) + | ClassifyOp.Sub_case_pi (n, ty, sz, sg) -> + (fun e1 e2 -> + typ_should_eq AST.ASTptr (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 + (AST.ASTptr, (AST.ASTint (AST.I32, AST.Signed)), AST.ASTptr, + (FrontEndOps.Osubpi AST.I32), (fix_ptr_type ty n e1), + (Cminor_syntax.Op1 ((AST.ASTint (AST.I16, sg)), (AST.ASTint + (AST.I32, AST.Signed)), (FrontEndOps.Ocastint (AST.I16, sg, AST.I32, + AST.Signed)), (Cminor_syntax.Op2 ((AST.ASTint (AST.I16, sg)), + (AST.ASTint (AST.I16, sg)), (AST.ASTint (AST.I16, sg)), + (FrontEndOps.Omul (AST.I16, sg)), (Cminor_syntax.Op1 ((AST.ASTint + (sz, sg)), (AST.ASTint (AST.I16, sg)), (FrontEndOps.Ocastint (sz, + sg, AST.I16, sg)), e2)), (Cminor_syntax.Cst ((AST.ASTint (AST.I16, + sg)), (FrontEndOps.Ointconst (AST.I16, sg, + (AST.repr AST.I16 (Csyntax.sizeof ty))))))))))))) + | ClassifyOp.Sub_case_pp (n1, n2, ty10, ty20) -> + (fun e1 e2 -> + match ty' with + | Csyntax.Tvoid -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz, sg) -> + Errors.OK (Cminor_syntax.Op1 ((AST.ASTint (AST.I32, AST.Unsigned)), + (AST.ASTint (sz, sg)), (FrontEndOps.Ocastint (AST.I32, + AST.Unsigned, sz, sg)), (Cminor_syntax.Op2 ((AST.ASTint (AST.I32, + AST.Unsigned)), (AST.ASTint (AST.I32, AST.Unsigned)), (AST.ASTint + (AST.I32, AST.Unsigned)), (FrontEndOps.Odivu AST.I32), + (Cminor_syntax.Op2 (AST.ASTptr, AST.ASTptr, (AST.ASTint (AST.I32, + AST.Unsigned)), (FrontEndOps.Osubpp AST.I32), + (fix_ptr_type ty10 n1 e1), (fix_ptr_type ty20 n2 e2))), + (Cminor_syntax.Cst ((AST.ASTint (AST.I32, AST.Unsigned)), + (FrontEndOps.Ointconst (AST.I32, AST.Unsigned, + (AST.repr AST.I32 (Csyntax.sizeof ty10)))))))))) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | ClassifyOp.Sub_default (x, x0) -> + (fun x1 x2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val translate_mul : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_mul ty1 ty2 ty' = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_aop ty1 ty2 with + | ClassifyOp.Aop_case_ii (sz, sg) -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, sg)) (Csyntax.typ_of_type ty') + (Cminor_syntax.Op2 ((AST.ASTint (sz, sg)), (AST.ASTint (sz, sg)), + (AST.ASTint (sz, sg)), (FrontEndOps.Omul (sz, sg)), e1, e2))) + | ClassifyOp.Aop_default (x, x0) -> + (fun x1 x2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val translate_div : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_div ty1 ty2 ty' = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_aop ty1 ty2 with + | ClassifyOp.Aop_case_ii (sz, sg) -> + (match sg with + | AST.Signed -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, AST.Signed)) + (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 ((AST.ASTint (sz, + AST.Signed)), (AST.ASTint (sz, AST.Signed)), (AST.ASTint (sz, + AST.Signed)), (FrontEndOps.Odiv sz), e1, e2))) + | AST.Unsigned -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, AST.Unsigned)) + (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 ((AST.ASTint (sz, + AST.Unsigned)), (AST.ASTint (sz, AST.Unsigned)), (AST.ASTint (sz, + AST.Unsigned)), (FrontEndOps.Odivu sz), e1, e2)))) + | ClassifyOp.Aop_default (x, x0) -> + (fun x1 x2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val translate_mod : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_mod ty1 ty2 ty' = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_aop ty1 ty2 with + | ClassifyOp.Aop_case_ii (sz, sg) -> + (match sg with + | AST.Signed -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, AST.Signed)) + (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 ((AST.ASTint (sz, + AST.Signed)), (AST.ASTint (sz, AST.Signed)), (AST.ASTint (sz, + AST.Signed)), (FrontEndOps.Omod sz), e1, e2))) + | AST.Unsigned -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, AST.Unsigned)) + (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 ((AST.ASTint (sz, + AST.Unsigned)), (AST.ASTint (sz, AST.Unsigned)), (AST.ASTint (sz, + AST.Unsigned)), (FrontEndOps.Omodu sz), e1, e2)))) + | ClassifyOp.Aop_default (x, x0) -> + (fun x1 x2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val translate_shr : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_shr ty1 ty2 ty' = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_aop ty1 ty2 with + | ClassifyOp.Aop_case_ii (sz, sg) -> + (match sg with + | AST.Signed -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, AST.Signed)) + (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 ((AST.ASTint (sz, + AST.Signed)), (AST.ASTint (sz, AST.Signed)), (AST.ASTint (sz, + AST.Signed)), (FrontEndOps.Oshr (sz, AST.Signed)), e1, e2))) + | AST.Unsigned -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, AST.Unsigned)) + (Csyntax.typ_of_type ty') (Cminor_syntax.Op2 ((AST.ASTint (sz, + AST.Unsigned)), (AST.ASTint (sz, AST.Unsigned)), (AST.ASTint (sz, + AST.Unsigned)), (FrontEndOps.Oshru (sz, AST.Unsigned)), e1, e2)))) + | ClassifyOp.Aop_default (x, x0) -> + (fun x1 x2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val complete_cmp : + Csyntax.type0 -> Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let complete_cmp ty' e = + match ty' with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz, sg) -> + Errors.OK (Cminor_syntax.Op1 ((AST.ASTint (AST.I8, AST.Unsigned)), + (AST.ASTint (sz, sg)), (FrontEndOps.Ocastint (AST.I8, AST.Unsigned, sz, + sg)), e)) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + +(** val translate_cmp : + Integers.comparison -> Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> + Cminor_syntax.expr -> Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_cmp c ty1 ty2 ty' = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_cmp ty1 ty2 with + | ClassifyOp.Cmp_case_ii (sz, sg) -> + (match sg with + | AST.Signed -> + (fun e1 e2 -> + complete_cmp ty' (Cminor_syntax.Op2 ((AST.ASTint (sz, AST.Signed)), + (AST.ASTint (sz, AST.Signed)), (AST.ASTint (AST.I8, + AST.Unsigned)), (FrontEndOps.Ocmp (sz, AST.Signed, AST.Unsigned, + c)), e1, e2))) + | AST.Unsigned -> + (fun e1 e2 -> + complete_cmp ty' (Cminor_syntax.Op2 ((AST.ASTint (sz, + AST.Unsigned)), (AST.ASTint (sz, AST.Unsigned)), (AST.ASTint + (AST.I8, AST.Unsigned)), (FrontEndOps.Ocmpu (sz, AST.Unsigned, + c)), e1, e2)))) + | ClassifyOp.Cmp_case_pp (n, ty) -> + (fun e1 e2 -> + complete_cmp ty' (Cminor_syntax.Op2 (AST.ASTptr, AST.ASTptr, + (AST.ASTint (AST.I8, AST.Unsigned)), (FrontEndOps.Ocmpp + (AST.Unsigned, c)), (fix_ptr_type ty n e1), (fix_ptr_type ty n e2)))) + | ClassifyOp.Cmp_default (x, x0) -> + (fun x1 x2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val translate_misc_aop : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> (AST.intsize -> + AST.signedness -> FrontEndOps.binary_operation) -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res **) +let translate_misc_aop ty1 ty2 ty' op = + let ty1' = Csyntax.typ_of_type ty1 in + let ty2' = Csyntax.typ_of_type ty2 in + (match ClassifyOp.classify_aop ty1 ty2 with + | ClassifyOp.Aop_case_ii (sz, sg) -> + (fun e1 e2 -> + typ_should_eq (AST.ASTint (sz, sg)) (Csyntax.typ_of_type ty') + (Cminor_syntax.Op2 ((Csyntax.typ_of_type (Csyntax.Tint (sz, sg))), + (Csyntax.typ_of_type (Csyntax.Tint (sz, sg))), (AST.ASTint (sz, + sg)), (op sz sg), e1, e2))) + | ClassifyOp.Aop_default (x, x0) -> + (fun x1 x2 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + +(** val translate_binop : + Csyntax.binary_operation -> Csyntax.type0 -> Cminor_syntax.expr -> + Csyntax.type0 -> Cminor_syntax.expr -> Csyntax.type0 -> + Cminor_syntax.expr Errors.res **) +let translate_binop op ty1 e1 ty2 e2 ty = + let ty' = Csyntax.typ_of_type ty in + (match op with + | Csyntax.Oadd -> translate_add ty1 ty2 ty e1 e2 + | Csyntax.Osub -> translate_sub ty1 ty2 ty e1 e2 + | Csyntax.Omul -> translate_mul ty1 ty2 ty e1 e2 + | Csyntax.Odiv -> translate_div ty1 ty2 ty e1 e2 + | Csyntax.Omod -> translate_mod ty1 ty2 ty e1 e2 + | Csyntax.Oand -> + translate_misc_aop ty1 ty2 ty (fun x x0 -> FrontEndOps.Oand (x, x0)) e1 + e2 + | Csyntax.Oor -> + translate_misc_aop ty1 ty2 ty (fun x x0 -> FrontEndOps.Oor (x, x0)) e1 + e2 + | Csyntax.Oxor -> + translate_misc_aop ty1 ty2 ty (fun x x0 -> FrontEndOps.Oxor (x, x0)) e1 + e2 + | Csyntax.Oshl -> + translate_misc_aop ty1 ty2 ty (fun x x0 -> FrontEndOps.Oshl (x, x0)) e1 + e2 + | Csyntax.Oshr -> translate_shr ty1 ty2 ty e1 e2 + | Csyntax.Oeq -> translate_cmp Integers.Ceq ty1 ty2 ty e1 e2 + | Csyntax.One -> translate_cmp Integers.Cne ty1 ty2 ty e1 e2 + | Csyntax.Olt -> translate_cmp Integers.Clt ty1 ty2 ty e1 e2 + | Csyntax.Ogt -> translate_cmp Integers.Cgt ty1 ty2 ty e1 e2 + | Csyntax.Ole -> translate_cmp Integers.Cle ty1 ty2 ty e1 e2 + | Csyntax.Oge -> translate_cmp Integers.Cge ty1 ty2 ty e1 e2) + +(** val translate_cast : + Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr Types.sig0 -> + Cminor_syntax.expr Types.sig0 Errors.res **) +let translate_cast ty1 ty2 = + match ty1 with + | Csyntax.Tvoid -> + (fun x -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tint (sz1, sg1) -> + (fun e -> + match ty2 with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz2, sg2) -> + Errors.OK (Cminor_syntax.Op1 ((AST.ASTint (sz1, sg1)), (AST.ASTint + (sz2, sg2)), (FrontEndOps.Ocastint (sz1, sg1, sz2, sg2)), + (Types.pi1 e))) + | Csyntax.Tpointer x -> + Errors.OK (Cminor_syntax.Op1 ((AST.ASTint (sz1, sg1)), AST.ASTptr, + (FrontEndOps.Optrofint (sz1, sg1)), (Types.pi1 e))) + | Csyntax.Tarray (x, x0) -> + Errors.OK (Cminor_syntax.Op1 ((AST.ASTint (sz1, sg1)), AST.ASTptr, + (FrontEndOps.Optrofint (sz1, sg1)), (Types.pi1 e))) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tpointer x -> + (fun e -> + match ty2 with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz2, sg2) -> + Errors.OK (Cminor_syntax.Op1 (AST.ASTptr, (AST.ASTint (sz2, sg2)), + (FrontEndOps.Ointofptr (sz2, sg2)), (Types.pi1 e))) + | Csyntax.Tpointer x0 -> Errors.OK e + | Csyntax.Tarray (x0, x1) -> Errors.OK e + | Csyntax.Tfunction (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x0 -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tarray (x, x0) -> + (fun e -> + match ty2 with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz2, sg2) -> + Errors.OK (Cminor_syntax.Op1 (AST.ASTptr, (AST.ASTint (sz2, sg2)), + (FrontEndOps.Ointofptr (sz2, sg2)), (Types.pi1 e))) + | Csyntax.Tpointer x1 -> Errors.OK e + | Csyntax.Tarray (x1, x2) -> Errors.OK e + | Csyntax.Tfunction (x1, x2) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x1, x2) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x1, x2) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x1 -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tfunction (x, x0) -> + (fun x1 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tstruct (x, x0) -> + (fun x1 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tunion (x, x0) -> + (fun x1 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tcomp_ptr x -> + (fun x0 -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + +(** val cm_zero : AST.intsize -> AST.signedness -> Cminor_syntax.expr **) +let cm_zero sz sg = + Cminor_syntax.Cst ((AST.ASTint (sz, sg)), (FrontEndOps.Ointconst (sz, sg, + (BitVector.zero (AST.bitsize_of_intsize sz))))) + +(** val cm_one : AST.intsize -> AST.signedness -> Cminor_syntax.expr **) +let cm_one sz sg = + Cminor_syntax.Cst ((AST.ASTint (sz, sg)), (FrontEndOps.Ointconst (sz, sg, + (AST.repr sz (Nat.S Nat.O))))) + +(** val translate_expr : + var_types -> Csyntax.expr -> Cminor_syntax.expr Types.sig0 Errors.res **) +let rec translate_expr vars = function +| Csyntax.Expr (ed, ty) -> + (match ed with + | Csyntax.Econst_int (sz, i) -> + (match ty with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz', sg) -> + AST.intsize_eq_elim' sz sz' (Errors.OK (Cminor_syntax.Cst + ((AST.ASTint (sz, sg)), (FrontEndOps.Ointconst (sz, sg, i))))) + (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Evar id -> + Errors.bind2_eq (lookup' vars id) (fun c t _ -> + (match c with + | Global r -> + (fun _ -> + match Csyntax.access_mode ty with + | Csyntax.By_value t0 -> + Errors.OK (Cminor_syntax.Mem (t0, (Cminor_syntax.Cst + (AST.ASTptr, (FrontEndOps.Oaddrsymbol (id, Nat.O)))))) + | Csyntax.By_reference -> + Errors.OK (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrsymbol (id, Nat.O)))) + | Csyntax.By_nothing x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BadlyTypedAccess), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil))))) + | Stack n -> + (fun _ -> + match Csyntax.access_mode ty with + | Csyntax.By_value t0 -> + Errors.OK (Cminor_syntax.Mem (t0, (Cminor_syntax.Cst + (AST.ASTptr, (FrontEndOps.Oaddrstack n))))) + | Csyntax.By_reference -> + Errors.OK (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrstack n))) + | Csyntax.By_nothing x -> + Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BadlyTypedAccess), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil))))) + | Local -> + (fun _ -> + type_should_eq t ty (Cminor_syntax.Id ((Csyntax.typ_of_type t), + id)))) __) + | Csyntax.Ederef e1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x, x0) -> + (fun x1 -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.TypeMismatch))) + | AST.ASTptr -> + (fun e1'0 -> + match Csyntax.access_mode ty with + | Csyntax.By_value t -> + Obj.magic (Errors.OK (Cminor_syntax.Mem (t, + (Types.pi1 e1'0)))) + | Csyntax.By_reference -> Obj.magic (Errors.OK e1'0) + | Csyntax.By_nothing x -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedAccess)))) e1')) + | Csyntax.Eaddrof e1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + match Csyntax.typ_of_type ty with + | AST.ASTint (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | AST.ASTptr -> Obj.magic (Errors.OK e1'))) + | Csyntax.Eunop (op, e1) -> + (match op with + | Csyntax.Onotbool -> + (fun _ -> + (match Csyntax.typ_of_type ty with + | AST.ASTint (sz, sg) -> + (fun _ -> + (match sz with + | AST.I8 -> + (fun _ -> Errors.Error + (Errors.msg ErrorMessages.TypeMismatch)) + | AST.I16 -> + (fun _ -> Errors.Error + (Errors.msg ErrorMessages.TypeMismatch)) + | AST.I32 -> + (fun _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (translate_unop + (Csyntax.typ_of_type (Csyntax.typeof e1)) + (Csyntax.typ_of_type ty) op)) (fun op' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (Cminor_syntax.Op1 + ((Csyntax.typ_of_type (Csyntax.typeof e1)), + (Csyntax.typ_of_type ty), op', (Types.pi1 e1'))))))))) + __) + | AST.ASTptr -> + (fun _ -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) + __) + | Csyntax.Onotint -> + (fun _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (translate_unop (Csyntax.typ_of_type (Csyntax.typeof e1)) + (Csyntax.typ_of_type ty) op)) (fun op' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (Cminor_syntax.Op1 + ((Csyntax.typ_of_type (Csyntax.typeof e1)), + (Csyntax.typ_of_type ty), op', (Types.pi1 e1')))))))) + | Csyntax.Oneg -> + (fun _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (translate_unop (Csyntax.typ_of_type (Csyntax.typeof e1)) + (Csyntax.typ_of_type ty) op)) (fun op' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (Cminor_syntax.Op1 + ((Csyntax.typ_of_type (Csyntax.typeof e1)), + (Csyntax.typ_of_type ty), op', (Types.pi1 e1'))))))))) __ + | Csyntax.Ebinop (op, e1, e2) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e2)) (fun e2' -> + Obj.magic + (Errors.bind_eq + (translate_binop op (Csyntax.typeof e1) (Types.pi1 e1') + (Csyntax.typeof e2) (Types.pi1 e2') ty) (fun e' _ -> + Errors.OK e'))))) + | Csyntax.Ecast (ty1, e1) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_cast (Csyntax.typeof e1) ty1 e1')) + (fun e' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (typ_should_eq (Csyntax.typ_of_type ty1) + (Csyntax.typ_of_type ty) e')) (fun e'0 -> + Obj.magic (Errors.OK e'0))))) + | Csyntax.Econdition (e1, e2, e3) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e2)) (fun e2' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (typ_should_eq (Csyntax.typ_of_type (Csyntax.typeof e2)) + (Csyntax.typ_of_type ty) e2')) (fun e2'0 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e3)) (fun e3' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (typ_should_eq (Csyntax.typ_of_type (Csyntax.typeof e3)) + (Csyntax.typ_of_type ty) e3')) (fun e3'0 -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x, x0) -> + (fun e1'0 -> + Obj.magic (Errors.OK (Cminor_syntax.Cond (x, x0, + (Csyntax.typ_of_type ty), (Types.pi1 e1'0), + (Types.pi1 e2'0), (Types.pi1 e3'0))))) + | AST.ASTptr -> + (fun x -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.TypeMismatch)))) e1')))))) + | Csyntax.Eandbool (e1, e2) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e2)) (fun e2' -> + match ty with + | Csyntax.Tvoid -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tint (sz, sg) -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (type_should_eq (Csyntax.typeof e2) (Csyntax.Tint (sz, sg)) + e2')) (fun e2'0 -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (sz1, x) -> + (fun e1'0 -> + Obj.magic (Errors.OK (Cminor_syntax.Cond (sz1, x, + (AST.ASTint (sz, sg)), (Types.pi1 e1'0), + (Cminor_syntax.Cond (sz, sg, (AST.ASTint (sz, sg)), + (Types.pi1 e2'0), (cm_one sz sg), (cm_zero sz sg))), + (cm_zero sz sg))))) + | AST.ASTptr -> + (fun x -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.TypeMismatch)))) e1') + | Csyntax.Tpointer x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tarray (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tfunction (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tstruct (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tunion (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tcomp_ptr x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch))))) + | Csyntax.Eorbool (e1, e2) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e2)) (fun e2' -> + match ty with + | Csyntax.Tvoid -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tint (sz, sg) -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (type_should_eq (Csyntax.typeof e2) (Csyntax.Tint (sz, sg)) + e2')) (fun e2'0 -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x, x0) -> + (fun e1'0 -> + Obj.magic (Errors.OK (Cminor_syntax.Cond (x, x0, + (AST.ASTint (sz, sg)), (Types.pi1 e1'0), + (cm_one sz sg), (Cminor_syntax.Cond (sz, sg, + (AST.ASTint (sz, sg)), (Types.pi1 e2'0), + (cm_one sz sg), (cm_zero sz sg))))))) + | AST.ASTptr -> + (fun x -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.TypeMismatch)))) e1') + | Csyntax.Tpointer x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tarray (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tfunction (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tstruct (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tunion (x, x0) -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Tcomp_ptr x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch))))) + | Csyntax.Esizeof ty1 -> + (match ty with + | Csyntax.Tvoid -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tint (sz, sg) -> + Errors.OK (Cminor_syntax.Cst ((AST.ASTint (sz, sg)), + (FrontEndOps.Ointconst (sz, sg, + (AST.repr sz (Csyntax.sizeof ty1)))))) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tstruct (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tunion (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch)) + | Csyntax.Efield (e1, id) -> + (match Csyntax.typeof e1 with + | Csyntax.Tvoid -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tint (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tpointer x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tarray (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tfunction (x, x0) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tstruct (x, fl) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Csyntax.field_offset id fl)) (fun off -> + match Csyntax.access_mode ty with + | Csyntax.By_value t -> + Obj.magic (Errors.OK (Cminor_syntax.Mem (t, + (Cminor_syntax.Op2 (AST.ASTptr, (AST.ASTint (AST.I16, + AST.Signed)), AST.ASTptr, (FrontEndOps.Oaddpi AST.I16), + (Types.pi1 e1'), (Cminor_syntax.Cst ((AST.ASTint (AST.I16, + AST.Signed)), (FrontEndOps.Ointconst (AST.I16, AST.Signed, + (AST.repr AST.I16 off)))))))))) + | Csyntax.By_reference -> + Obj.magic (Errors.OK (Cminor_syntax.Op2 (AST.ASTptr, + (AST.ASTint (AST.I16, AST.Signed)), AST.ASTptr, + (FrontEndOps.Oaddpi AST.I16), (Types.pi1 e1'), + (Cminor_syntax.Cst ((AST.ASTint (AST.I16, AST.Signed)), + (FrontEndOps.Ointconst (AST.I16, AST.Signed, + (AST.repr AST.I16 off)))))))) + | Csyntax.By_nothing x0 -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedAccess))))) + | Csyntax.Tunion (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + match Csyntax.access_mode ty with + | Csyntax.By_value t -> + Obj.magic (Errors.OK (Cminor_syntax.Mem (t, (Types.pi1 e1')))) + | Csyntax.By_reference -> Obj.magic (Errors.OK e1') + | Csyntax.By_nothing x1 -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedAccess)))) + | Csyntax.Tcomp_ptr x -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess)) + | Csyntax.Ecost (l, e1) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Errors.OK (Cminor_syntax.Ecost + ((Csyntax.typ_of_type (Csyntax.typeof e1)), l, + (Types.pi1 e1'))))) (fun e' -> + Obj.magic + (typ_should_eq (Csyntax.typ_of_type (Csyntax.typeof e1)) + (Csyntax.typ_of_type ty) e'))))) +(** val translate_addr : + var_types -> Csyntax.expr -> Cminor_syntax.expr Types.sig0 Errors.res **) +and translate_addr vars = function +| Csyntax.Expr (ed, x) -> + (match ed with + | Csyntax.Econst_int (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Evar id -> + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (lookup' vars id)) (fun c t -> + match c with + | Global r -> + Obj.magic (Errors.OK (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrsymbol (id, Nat.O))))) + | Stack n -> + Obj.magic (Errors.OK (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrstack n)))) + | Local -> + Obj.magic (Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.BadlyTypedAccess), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil))))))) + | Csyntax.Ederef e1 -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x0, x1) -> + (fun x2 -> + Obj.magic (Errors.Error + (Errors.msg ErrorMessages.BadlyTypedAccess))) + | AST.ASTptr -> (fun e1'0 -> Obj.magic (Errors.OK e1'0))) e1')) + | Csyntax.Eaddrof x0 -> Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Eunop (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Ebinop (x0, x1, x2) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Ecast (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Econdition (x0, x1, x2) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Eandbool (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Eorbool (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Esizeof x0 -> Errors.Error (Errors.msg ErrorMessages.BadLvalue) + | Csyntax.Efield (e1, id) -> + (match Csyntax.typeof e1 with + | Csyntax.Tvoid -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tint (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tpointer x0 -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tarray (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tfunction (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess) + | Csyntax.Tstruct (x0, fl) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Csyntax.field_offset id fl)) (fun off -> + Obj.magic (Errors.OK (Cminor_syntax.Op2 (AST.ASTptr, + (AST.ASTint (AST.I16, AST.Signed)), AST.ASTptr, + (FrontEndOps.Oaddpi AST.I16), (Types.pi1 e1'), + (Cminor_syntax.Cst ((AST.ASTint (AST.I16, AST.Signed)), + (FrontEndOps.Ointconst (AST.I16, AST.Signed, + (AST.repr AST.I16 off))))))))))) + | Csyntax.Tunion (x0, x1) -> translate_addr vars e1 + | Csyntax.Tcomp_ptr x0 -> + Errors.Error (Errors.msg ErrorMessages.BadlyTypedAccess)) + | Csyntax.Ecost (x0, x1) -> + Errors.Error (Errors.msg ErrorMessages.BadLvalue)) + +type destination = +| IdDest of AST.ident +| MemDest of Cminor_syntax.expr Types.sig0 + +(** val destination_rect_Type4 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 **) +let rec destination_rect_Type4 vars t h_IdDest h_MemDest = function +| IdDest id -> h_IdDest id __ +| MemDest x_14524 -> h_MemDest x_14524 + +(** val destination_rect_Type5 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 **) +let rec destination_rect_Type5 vars t h_IdDest h_MemDest = function +| IdDest id -> h_IdDest id __ +| MemDest x_14529 -> h_MemDest x_14529 + +(** val destination_rect_Type3 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 **) +let rec destination_rect_Type3 vars t h_IdDest h_MemDest = function +| IdDest id -> h_IdDest id __ +| MemDest x_14534 -> h_MemDest x_14534 + +(** val destination_rect_Type2 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 **) +let rec destination_rect_Type2 vars t h_IdDest h_MemDest = function +| IdDest id -> h_IdDest id __ +| MemDest x_14539 -> h_MemDest x_14539 + +(** val destination_rect_Type1 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 **) +let rec destination_rect_Type1 vars t h_IdDest h_MemDest = function +| IdDest id -> h_IdDest id __ +| MemDest x_14544 -> h_MemDest x_14544 + +(** val destination_rect_Type0 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 **) +let rec destination_rect_Type0 vars t h_IdDest h_MemDest = function +| IdDest id -> h_IdDest id __ +| MemDest x_14549 -> h_MemDest x_14549 + +(** val destination_inv_rect_Type4 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 **) +let destination_inv_rect_Type4 x1 x2 hterm h1 h2 = + let hcut = destination_rect_Type4 x1 x2 h1 h2 hterm in hcut __ + +(** val destination_inv_rect_Type3 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 **) +let destination_inv_rect_Type3 x1 x2 hterm h1 h2 = + let hcut = destination_rect_Type3 x1 x2 h1 h2 hterm in hcut __ + +(** val destination_inv_rect_Type2 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 **) +let destination_inv_rect_Type2 x1 x2 hterm h1 h2 = + let hcut = destination_rect_Type2 x1 x2 h1 h2 hterm in hcut __ + +(** val destination_inv_rect_Type1 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 **) +let destination_inv_rect_Type1 x1 x2 hterm h1 h2 = + let hcut = destination_rect_Type1 x1 x2 h1 h2 hterm in hcut __ + +(** val destination_inv_rect_Type0 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 **) +let destination_inv_rect_Type0 x1 x2 hterm h1 h2 = + let hcut = destination_rect_Type0 x1 x2 h1 h2 hterm in hcut __ + +(** val destination_discr : + var_types -> AST.typ -> destination -> destination -> __ **) +let destination_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | IdDest a0 -> Obj.magic (fun _ dH -> dH __ __) + | MemDest a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val destination_jmdiscr : + var_types -> AST.typ -> destination -> destination -> __ **) +let destination_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | IdDest a0 -> Obj.magic (fun _ dH -> dH __ __) + | MemDest a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val translate_dest : + var_types -> Csyntax.expr -> destination Errors.res **) +let translate_dest vars e1 = match e1 with +| Csyntax.Expr (ed1, ty1) -> + (match ed1 with + | Csyntax.Econst_int (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Evar id -> + Errors.bind2_eq (lookup' vars id) (fun c t _ -> + (match c with + | Global r -> + (fun _ -> Errors.OK (MemDest (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrsymbol (id, Nat.O)))))) + | Stack n -> + (fun _ -> Errors.OK (MemDest (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrstack n))))) + | Local -> + (fun _ -> + match AST.typ_eq (Csyntax.typ_of_type ty1) + (Csyntax.typ_of_type t) with + | Types.Inl _ -> Errors.OK (IdDest id) + | Types.Inr _ -> + Errors.Error (Errors.msg ErrorMessages.TypeMismatch))) __) + | Csyntax.Ederef x -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Eaddrof x -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Eunop (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Ebinop (x, x0, x1) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Ecast (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Econdition (x, x0, x1) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Eandbool (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Eorbool (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Esizeof x -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Efield (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1')))) + | Csyntax.Ecost (x, x0) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_addr vars e1)) (fun e1' -> + Obj.magic (Errors.OK (MemDest e1'))))) + +type lenv = PreIdentifiers.identifier Identifiers.identifier_map + +(** val lookup_label : + lenv -> PreIdentifiers.identifier -> PreIdentifiers.identifier Errors.res **) +let lookup_label lbls l = + Errors.opt_to_res (List.Cons ((Errors.MSG ErrorMessages.MissingLabel), + (List.Cons ((Errors.CTX (PreIdentifiers.SymbolTag, l)), List.Nil)))) + (Identifiers.lookup PreIdentifiers.SymbolTag lbls l) + +type labgen = { labuniverse : Identifiers.universe; + label_genlist : PreIdentifiers.identifier List.list } + +(** val labgen_rect_Type4 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> + 'a1) -> labgen -> 'a1 **) +let rec labgen_rect_Type4 h_mk_labgen x_14584 = + let { labuniverse = labuniverse0; label_genlist = label_genlist0 } = + x_14584 + in + h_mk_labgen labuniverse0 label_genlist0 __ + +(** val labgen_rect_Type5 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> + 'a1) -> labgen -> 'a1 **) +let rec labgen_rect_Type5 h_mk_labgen x_14586 = + let { labuniverse = labuniverse0; label_genlist = label_genlist0 } = + x_14586 + in + h_mk_labgen labuniverse0 label_genlist0 __ + +(** val labgen_rect_Type3 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> + 'a1) -> labgen -> 'a1 **) +let rec labgen_rect_Type3 h_mk_labgen x_14588 = + let { labuniverse = labuniverse0; label_genlist = label_genlist0 } = + x_14588 + in + h_mk_labgen labuniverse0 label_genlist0 __ + +(** val labgen_rect_Type2 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> + 'a1) -> labgen -> 'a1 **) +let rec labgen_rect_Type2 h_mk_labgen x_14590 = + let { labuniverse = labuniverse0; label_genlist = label_genlist0 } = + x_14590 + in + h_mk_labgen labuniverse0 label_genlist0 __ + +(** val labgen_rect_Type1 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> + 'a1) -> labgen -> 'a1 **) +let rec labgen_rect_Type1 h_mk_labgen x_14592 = + let { labuniverse = labuniverse0; label_genlist = label_genlist0 } = + x_14592 + in + h_mk_labgen labuniverse0 label_genlist0 __ + +(** val labgen_rect_Type0 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> + 'a1) -> labgen -> 'a1 **) +let rec labgen_rect_Type0 h_mk_labgen x_14594 = + let { labuniverse = labuniverse0; label_genlist = label_genlist0 } = + x_14594 + in + h_mk_labgen labuniverse0 label_genlist0 __ + +(** val labuniverse : labgen -> Identifiers.universe **) +let rec labuniverse xxx = + xxx.labuniverse + +(** val label_genlist : labgen -> PreIdentifiers.identifier List.list **) +let rec label_genlist xxx = + xxx.label_genlist + +(** val labgen_inv_rect_Type4 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 **) +let labgen_inv_rect_Type4 hterm h1 = + let hcut = labgen_rect_Type4 h1 hterm in hcut __ + +(** val labgen_inv_rect_Type3 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 **) +let labgen_inv_rect_Type3 hterm h1 = + let hcut = labgen_rect_Type3 h1 hterm in hcut __ + +(** val labgen_inv_rect_Type2 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 **) +let labgen_inv_rect_Type2 hterm h1 = + let hcut = labgen_rect_Type2 h1 hterm in hcut __ + +(** val labgen_inv_rect_Type1 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 **) +let labgen_inv_rect_Type1 hterm h1 = + let hcut = labgen_rect_Type1 h1 hterm in hcut __ + +(** val labgen_inv_rect_Type0 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 **) +let labgen_inv_rect_Type0 hterm h1 = + let hcut = labgen_rect_Type0 h1 hterm in hcut __ + +(** val labgen_discr : labgen -> labgen -> __ **) +let labgen_discr x y = + Logic.eq_rect_Type2 x + (let { labuniverse = a0; label_genlist = a1 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val labgen_jmdiscr : labgen -> labgen -> __ **) +let labgen_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { labuniverse = a0; label_genlist = a1 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val generate_fresh_label : + labgen -> (PreIdentifiers.identifier, labgen) Types.prod Types.sig0 **) +let generate_fresh_label ul = + (let { Types.fst = tmp; Types.snd = u } = + Identifiers.fresh PreIdentifiers.Label ul.labuniverse + in + (fun _ -> { Types.fst = tmp; Types.snd = { labuniverse = u; label_genlist = + (List.Cons (tmp, ul.label_genlist)) } })) __ + +(** val labels_defined : Csyntax.statement -> AST.ident List.list **) +let rec labels_defined = function +| Csyntax.Sskip -> List.Nil +| Csyntax.Sassign (x, x0) -> List.Nil +| Csyntax.Scall (x, x0, x1) -> List.Nil +| Csyntax.Ssequence (s1, s2) -> + List.append (labels_defined s1) (labels_defined s2) +| Csyntax.Sifthenelse (x, s1, s2) -> + List.append (labels_defined s1) (labels_defined s2) +| Csyntax.Swhile (x, s0) -> labels_defined s0 +| Csyntax.Sdowhile (x, s0) -> labels_defined s0 +| Csyntax.Sfor (s1, x, s2, s3) -> + List.append (labels_defined s1) + (List.append (labels_defined s2) (labels_defined s3)) +| Csyntax.Sbreak -> List.Nil +| Csyntax.Scontinue -> List.Nil +| Csyntax.Sreturn x -> List.Nil +| Csyntax.Sswitch (x, ls) -> labels_defined_switch ls +| Csyntax.Slabel (l, s0) -> List.Cons (l, (labels_defined s0)) +| Csyntax.Sgoto x -> List.Nil +| Csyntax.Scost (x, s0) -> labels_defined s0 +(** val labels_defined_switch : + Csyntax.labeled_statements -> AST.ident List.list **) +and labels_defined_switch = function +| Csyntax.LSdefault s -> labels_defined s +| Csyntax.LScase (x, x0, s, ls0) -> + List.append (labels_defined s) (labels_defined_switch ls0) + +(** val m_option_map : + ('a1 -> 'a2 Errors.res) -> 'a1 Types.option -> 'a2 Types.option + Errors.res **) +let m_option_map f = function +| Types.None -> Errors.OK Types.None +| Types.Some a -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic f a) (fun b -> + Obj.magic (Errors.OK (Types.Some b)))) + +(** val translate_expr_sigma : + var_types -> Csyntax.expr -> (AST.typ, Cminor_syntax.expr) Types.dPair + Types.sig0 Errors.res **) +let translate_expr_sigma v e = + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr v e)) (fun e' -> + Obj.magic (Errors.OK { Types.dpi1 = + (Csyntax.typ_of_type (Csyntax.typeof e)); Types.dpi2 = + (Types.pi1 e') }))) + +(** val add_tmps : + var_types -> (AST.ident, Csyntax.type0) Types.prod List.list -> var_types **) +let add_tmps vs tmpenv = + List.foldr (fun idty vs0 -> + Identifiers.add PreIdentifiers.SymbolTag vs0 idty.Types.fst { Types.fst = + Local; Types.snd = idty.Types.snd }) vs tmpenv + +type tmpgen = { tmp_universe : Identifiers.universe; + tmp_env : (AST.ident, Csyntax.type0) Types.prod List.list } + +(** val tmpgen_rect_Type4 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 **) +let rec tmpgen_rect_Type4 vars h_mk_tmpgen x_14610 = + let { tmp_universe = tmp_universe0; tmp_env = tmp_env0 } = x_14610 in + h_mk_tmpgen tmp_universe0 tmp_env0 __ __ + +(** val tmpgen_rect_Type5 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 **) +let rec tmpgen_rect_Type5 vars h_mk_tmpgen x_14612 = + let { tmp_universe = tmp_universe0; tmp_env = tmp_env0 } = x_14612 in + h_mk_tmpgen tmp_universe0 tmp_env0 __ __ + +(** val tmpgen_rect_Type3 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 **) +let rec tmpgen_rect_Type3 vars h_mk_tmpgen x_14614 = + let { tmp_universe = tmp_universe0; tmp_env = tmp_env0 } = x_14614 in + h_mk_tmpgen tmp_universe0 tmp_env0 __ __ + +(** val tmpgen_rect_Type2 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 **) +let rec tmpgen_rect_Type2 vars h_mk_tmpgen x_14616 = + let { tmp_universe = tmp_universe0; tmp_env = tmp_env0 } = x_14616 in + h_mk_tmpgen tmp_universe0 tmp_env0 __ __ + +(** val tmpgen_rect_Type1 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 **) +let rec tmpgen_rect_Type1 vars h_mk_tmpgen x_14618 = + let { tmp_universe = tmp_universe0; tmp_env = tmp_env0 } = x_14618 in + h_mk_tmpgen tmp_universe0 tmp_env0 __ __ + +(** val tmpgen_rect_Type0 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 **) +let rec tmpgen_rect_Type0 vars h_mk_tmpgen x_14620 = + let { tmp_universe = tmp_universe0; tmp_env = tmp_env0 } = x_14620 in + h_mk_tmpgen tmp_universe0 tmp_env0 __ __ + +(** val tmp_universe : var_types -> tmpgen -> Identifiers.universe **) +let rec tmp_universe vars xxx = + xxx.tmp_universe + +(** val tmp_env : + var_types -> tmpgen -> (AST.ident, Csyntax.type0) Types.prod List.list **) +let rec tmp_env vars xxx = + xxx.tmp_env + +(** val tmpgen_inv_rect_Type4 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, + Csyntax.type0) Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let tmpgen_inv_rect_Type4 x1 hterm h1 = + let hcut = tmpgen_rect_Type4 x1 h1 hterm in hcut __ + +(** val tmpgen_inv_rect_Type3 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, + Csyntax.type0) Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let tmpgen_inv_rect_Type3 x1 hterm h1 = + let hcut = tmpgen_rect_Type3 x1 h1 hterm in hcut __ + +(** val tmpgen_inv_rect_Type2 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, + Csyntax.type0) Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let tmpgen_inv_rect_Type2 x1 hterm h1 = + let hcut = tmpgen_rect_Type2 x1 h1 hterm in hcut __ + +(** val tmpgen_inv_rect_Type1 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, + Csyntax.type0) Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let tmpgen_inv_rect_Type1 x1 hterm h1 = + let hcut = tmpgen_rect_Type1 x1 h1 hterm in hcut __ + +(** val tmpgen_inv_rect_Type0 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, + Csyntax.type0) Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let tmpgen_inv_rect_Type0 x1 hterm h1 = + let hcut = tmpgen_rect_Type0 x1 h1 hterm in hcut __ + +(** val tmpgen_discr : var_types -> tmpgen -> tmpgen -> __ **) +let tmpgen_discr a1 x y = + Logic.eq_rect_Type2 x + (let { tmp_universe = a0; tmp_env = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val tmpgen_jmdiscr : var_types -> tmpgen -> tmpgen -> __ **) +let tmpgen_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { tmp_universe = a0; tmp_env = a10 } = x in + Obj.magic (fun _ dH -> dH __ __ __ __)) y + +(** val alloc_tmp : + var_types -> Csyntax.type0 -> tmpgen -> (AST.ident, tmpgen) Types.prod **) +let alloc_tmp vars ty g = + (let { Types.fst = tmp; Types.snd = u } = + Identifiers.fresh PreIdentifiers.SymbolTag g.tmp_universe + in + (fun _ -> { Types.fst = tmp; Types.snd = { tmp_universe = u; tmp_env = + (List.Cons ({ Types.fst = tmp; Types.snd = ty }, g.tmp_env)) } })) __ + +(** val mklabels : + labgen -> ((PreIdentifiers.identifier, PreIdentifiers.identifier) + Types.prod, labgen) Types.prod **) +let rec mklabels ul = + let res1 = generate_fresh_label ul in + (let { Types.fst = entry_label; Types.snd = ul1 } = res1 in + (fun _ -> + let res2 = generate_fresh_label ul1 in + (let { Types.fst = exit_label; Types.snd = ul2 } = res2 in + (fun _ -> { Types.fst = { Types.fst = entry_label; Types.snd = + exit_label }; Types.snd = ul2 })) __)) __ + +type convert_flag = +| DoNotConvert +| ConvertTo of PreIdentifiers.identifier * PreIdentifiers.identifier + +(** val convert_flag_rect_Type4 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 **) +let rec convert_flag_rect_Type4 h_DoNotConvert h_ConvertTo = function +| DoNotConvert -> h_DoNotConvert +| ConvertTo (x_14642, x_14641) -> h_ConvertTo x_14642 x_14641 + +(** val convert_flag_rect_Type5 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 **) +let rec convert_flag_rect_Type5 h_DoNotConvert h_ConvertTo = function +| DoNotConvert -> h_DoNotConvert +| ConvertTo (x_14647, x_14646) -> h_ConvertTo x_14647 x_14646 + +(** val convert_flag_rect_Type3 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 **) +let rec convert_flag_rect_Type3 h_DoNotConvert h_ConvertTo = function +| DoNotConvert -> h_DoNotConvert +| ConvertTo (x_14652, x_14651) -> h_ConvertTo x_14652 x_14651 + +(** val convert_flag_rect_Type2 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 **) +let rec convert_flag_rect_Type2 h_DoNotConvert h_ConvertTo = function +| DoNotConvert -> h_DoNotConvert +| ConvertTo (x_14657, x_14656) -> h_ConvertTo x_14657 x_14656 + +(** val convert_flag_rect_Type1 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 **) +let rec convert_flag_rect_Type1 h_DoNotConvert h_ConvertTo = function +| DoNotConvert -> h_DoNotConvert +| ConvertTo (x_14662, x_14661) -> h_ConvertTo x_14662 x_14661 + +(** val convert_flag_rect_Type0 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 **) +let rec convert_flag_rect_Type0 h_DoNotConvert h_ConvertTo = function +| DoNotConvert -> h_DoNotConvert +| ConvertTo (x_14667, x_14666) -> h_ConvertTo x_14667 x_14666 + +(** val convert_flag_inv_rect_Type4 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 **) +let convert_flag_inv_rect_Type4 hterm h1 h2 = + let hcut = convert_flag_rect_Type4 h1 h2 hterm in hcut __ + +(** val convert_flag_inv_rect_Type3 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 **) +let convert_flag_inv_rect_Type3 hterm h1 h2 = + let hcut = convert_flag_rect_Type3 h1 h2 hterm in hcut __ + +(** val convert_flag_inv_rect_Type2 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 **) +let convert_flag_inv_rect_Type2 hterm h1 h2 = + let hcut = convert_flag_rect_Type2 h1 h2 hterm in hcut __ + +(** val convert_flag_inv_rect_Type1 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 **) +let convert_flag_inv_rect_Type1 hterm h1 h2 = + let hcut = convert_flag_rect_Type1 h1 h2 hterm in hcut __ + +(** val convert_flag_inv_rect_Type0 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 **) +let convert_flag_inv_rect_Type0 hterm h1 h2 = + let hcut = convert_flag_rect_Type0 h1 h2 hterm in hcut __ + +(** val convert_flag_discr : convert_flag -> convert_flag -> __ **) +let convert_flag_discr x y = + Logic.eq_rect_Type2 x + (match x with + | DoNotConvert -> Obj.magic (fun _ dH -> dH) + | ConvertTo (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val convert_flag_jmdiscr : convert_flag -> convert_flag -> __ **) +let convert_flag_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | DoNotConvert -> Obj.magic (fun _ dH -> dH) + | ConvertTo (a0, a1) -> Obj.magic (fun _ dH -> dH __ __)) y + +(** val labels_of_flag : + convert_flag -> PreIdentifiers.identifier List.list **) +let rec labels_of_flag = function +| DoNotConvert -> List.Nil +| ConvertTo (continue, break) -> + List.Cons (continue, (List.Cons (break, List.Nil))) + +(** val translate_statement : + var_types -> tmpgen -> labgen -> lenv -> convert_flag -> AST.typ + Types.option -> Csyntax.statement -> ((tmpgen, labgen) Types.prod, + Cminor_syntax.stmt) Types.prod Types.sig0 Errors.res **) +let rec translate_statement vars uv ul lbls flag rettyp = function +| Csyntax.Sskip -> + Errors.OK { Types.fst = { Types.fst = uv; Types.snd = ul }; Types.snd = + Cminor_syntax.St_skip } +| Csyntax.Sassign (e1, e2) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e2)) (fun e2' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_dest vars e1)) (fun dest -> + match dest with + | IdDest id -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (typ_should_eq (Csyntax.typ_of_type (Csyntax.typeof e2)) + (Csyntax.typ_of_type (Csyntax.typeof e1)) e2')) (fun e2'0 -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = uv; Types.snd = + ul }; Types.snd = (Cminor_syntax.St_assign + ((Csyntax.typ_of_type (Csyntax.typeof e1)), id, + (Types.pi1 e2'0))) })) + | MemDest e1' -> + (match TypeComparison.type_eq_dec (Csyntax.typeof e1) + (Csyntax.typeof e2) with + | Types.Inl _ -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = uv; Types.snd = + ul }; Types.snd = (Cminor_syntax.St_store + ((Csyntax.typ_of_type (Csyntax.typeof e2)), (Types.pi1 e1'), + (Types.pi1 e2'))) }) + | Types.Inr _ -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)))))) +| Csyntax.Scall (ret, ef, args) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars ef)) (fun ef' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (typ_should_eq (Csyntax.typ_of_type (Csyntax.typeof ef)) AST.ASTptr + ef')) (fun ef'0 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Errors.mmap_sigma (Obj.magic (translate_expr_sigma vars)) args) + (fun args' -> + match ret with + | Types.None -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = uv; Types.snd = + ul }; Types.snd = (Cminor_syntax.St_call (Types.None, + (Types.pi1 ef'0), (Types.pi1 args'))) }) + | Types.Some e1 -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_dest vars e1)) (fun dest -> + match dest with + | IdDest id -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = uv; + Types.snd = ul }; Types.snd = (Cminor_syntax.St_call + ((Types.Some { Types.fst = id; Types.snd = + (Csyntax.typ_of_type (Csyntax.typeof e1)) }), + (Types.pi1 ef'0), (Types.pi1 args'))) }) + | MemDest e1' -> + (let { Types.fst = tmp; Types.snd = uv1 } = + alloc_tmp vars (Csyntax.typeof e1) uv + in + (fun _ -> + (let { Types.fst = tmp2; Types.snd = uv2 } = + alloc_tmp vars (Csyntax.Tpointer (Csyntax.typeof e1)) uv1 + in + (fun _ -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = uv2; + Types.snd = ul }; Types.snd = (Cminor_syntax.St_seq + ((Cminor_syntax.St_assign (AST.ASTptr, tmp2, + (Types.pi1 e1'))), (Cminor_syntax.St_seq + ((Cminor_syntax.St_call ((Types.Some { Types.fst = tmp; + Types.snd = (Csyntax.typ_of_type (Csyntax.typeof e1)) }), + (Types.pi1 ef'0), (Types.pi1 args'))), + (Cminor_syntax.St_store + ((Csyntax.typ_of_type (Csyntax.typeof e1)), + (Cminor_syntax.Id (AST.ASTptr, tmp2)), (Cminor_syntax.Id + ((Csyntax.typ_of_type (Csyntax.typeof e1)), tmp)))))))) }))) + __)) __))))) +| Csyntax.Ssequence (s1, s2) -> + Obj.magic + (Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic (translate_statement vars uv ul lbls flag rettyp s1)) + (fun fgens1 s1' _ -> + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vars fgens1.Types.fst fgens1.Types.snd lbls + flag rettyp s2)) (fun fgens2 s2' _ -> + Obj.magic (Errors.OK { Types.fst = fgens2; Types.snd = + (Cminor_syntax.St_seq (s1', s2')) })))) +| Csyntax.Sifthenelse (e1, s1, s2) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x, x0) -> + (fun e1'0 -> + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic (translate_statement vars uv ul lbls flag rettyp s1)) + (fun fgens1 s1' _ -> + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vars fgens1.Types.fst fgens1.Types.snd + lbls flag rettyp s2)) (fun fgens2 s2' _ -> + Obj.magic (Errors.OK { Types.fst = fgens2; Types.snd = + (Cminor_syntax.St_ifthenelse (x, x0, (Types.pi1 e1'0), s1', + s2')) })))) + | AST.ASTptr -> + (fun x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)))) + e1')) +| Csyntax.Swhile (e1, s1) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x, x0) -> + (fun e1'0 -> + (let { Types.fst = labels; Types.snd = ul1 } = mklabels ul in + (fun _ -> + (let { Types.fst = entry; Types.snd = exit } = labels in + (fun _ -> + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vars uv ul1 lbls (ConvertTo (entry, + exit)) rettyp s1)) (fun fgens2 s1' _ -> + let converted_loop = Cminor_syntax.St_label (entry, + (Cminor_syntax.St_seq ((Cminor_syntax.St_ifthenelse (x, x0, + (Types.pi1 e1'0), (Cminor_syntax.St_seq (s1', + (Cminor_syntax.St_goto entry))), Cminor_syntax.St_skip)), + (Cminor_syntax.St_label (exit, Cminor_syntax.St_skip))))) + in + Obj.magic (Errors.OK { Types.fst = fgens2; Types.snd = + converted_loop })))) __)) __) + | AST.ASTptr -> + (fun x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)))) + e1')) +| Csyntax.Sdowhile (e1, s1) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x, x0) -> + (fun e1'0 -> + (let { Types.fst = labels; Types.snd = ul1 } = mklabels ul in + (fun _ -> + (let { Types.fst = condexpr; Types.snd = exit } = labels in + (fun _ -> + let { Types.fst = body; Types.snd = ul2 } = + Types.pi1 (generate_fresh_label ul1) + in + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vars uv ul2 lbls (ConvertTo (condexpr, + exit)) rettyp s1)) (fun fgens2 s1' _ -> + let converted_loop = Cminor_syntax.St_seq ((Cminor_syntax.St_seq + ((Cminor_syntax.St_goto body), (Cminor_syntax.St_label + (condexpr, (Cminor_syntax.St_ifthenelse (x, x0, + (Types.pi1 e1'0), (Cminor_syntax.St_label (body, + (Cminor_syntax.St_seq (s1', (Cminor_syntax.St_goto + condexpr))))), Cminor_syntax.St_skip)))))), + (Cminor_syntax.St_label (exit, Cminor_syntax.St_skip))) + in + Obj.magic (Errors.OK { Types.fst = fgens2; Types.snd = + converted_loop })))) __)) __) + | AST.ASTptr -> + (fun x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)))) + e1')) +| Csyntax.Sfor (s1, e1, s2, s3) -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + (match Csyntax.typ_of_type (Csyntax.typeof e1) with + | AST.ASTint (x, x0) -> + (fun e1'0 -> + (let { Types.fst = labels; Types.snd = ul1 } = mklabels ul in + (fun _ -> + (let { Types.fst = continue; Types.snd = exit } = labels in + (fun _ -> + let { Types.fst = entry; Types.snd = ul2 } = + Types.pi1 (generate_fresh_label ul1) + in + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vars uv ul2 lbls flag rettyp s1)) + (fun fgens2 s1' _ -> + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vars fgens2.Types.fst fgens2.Types.snd + lbls flag rettyp s2)) (fun fgens3 s2' _ -> + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vars fgens3.Types.fst + fgens3.Types.snd lbls (ConvertTo (continue, exit)) + rettyp s3)) (fun fgens4 s3' _ -> + let converted_loop = Cminor_syntax.St_seq (s1', + (Cminor_syntax.St_label (entry, (Cminor_syntax.St_seq + ((Cminor_syntax.St_ifthenelse (x, x0, (Types.pi1 e1'0), + (Cminor_syntax.St_seq (s3', (Cminor_syntax.St_label + (continue, (Cminor_syntax.St_seq (s2', + (Cminor_syntax.St_goto entry))))))), + Cminor_syntax.St_skip)), (Cminor_syntax.St_label (exit, + Cminor_syntax.St_skip))))))) + in + Obj.magic (Errors.OK { Types.fst = fgens4; Types.snd = + converted_loop })))))) __)) __) + | AST.ASTptr -> + (fun x -> + Obj.magic (Errors.Error (Errors.msg ErrorMessages.TypeMismatch)))) + e1')) +| Csyntax.Sbreak -> + (match flag with + | DoNotConvert -> (fun _ -> Errors.Error (Errors.msg ErrorMessages.FIXME)) + | ConvertTo (continue_label, break_label) -> + (fun _ -> Errors.OK { Types.fst = { Types.fst = uv; Types.snd = ul }; + Types.snd = (Cminor_syntax.St_goto break_label) })) __ +| Csyntax.Scontinue -> + (match flag with + | DoNotConvert -> (fun _ -> Errors.Error (Errors.msg ErrorMessages.FIXME)) + | ConvertTo (continue_label, break_label) -> + (fun _ -> Errors.OK { Types.fst = { Types.fst = uv; Types.snd = ul }; + Types.snd = (Cminor_syntax.St_goto continue_label) })) __ +| Csyntax.Sreturn ret -> + (match ret with + | Types.None -> + (match rettyp with + | Types.None -> + Errors.OK { Types.fst = { Types.fst = uv; Types.snd = ul }; + Types.snd = (Cminor_syntax.St_return Types.None) } + | Types.Some x -> + Errors.Error (Errors.msg ErrorMessages.ReturnMismatch)) + | Types.Some e1 -> + (match rettyp with + | Types.None -> Errors.Error (Errors.msg ErrorMessages.ReturnMismatch) + | Types.Some rty -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_expr vars e1)) (fun e1' -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (typ_should_eq (Csyntax.typ_of_type (Csyntax.typeof e1)) rty + e1')) (fun e1'0 -> + Obj.magic (Errors.OK { Types.fst = { Types.fst = uv; + Types.snd = ul }; Types.snd = (Cminor_syntax.St_return + (Types.Some { Types.dpi1 = rty; Types.dpi2 = + (Types.pi1 e1'0) })) })))))) +| Csyntax.Sswitch (e1, ls) -> Errors.Error (Errors.msg ErrorMessages.FIXME) +| Csyntax.Slabel (l, s1) -> + Errors.bind_eq (lookup_label lbls l) (fun l' _ -> + Obj.magic + (Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic (translate_statement vars uv ul lbls flag rettyp s1)) + (fun fgens1 s1' _ -> + Obj.magic (Errors.OK { Types.fst = fgens1; Types.snd = + (Cminor_syntax.St_label (l', s1')) })))) +| Csyntax.Sgoto l -> + Errors.bind_eq (lookup_label lbls l) (fun l' _ -> Errors.OK { Types.fst = + { Types.fst = uv; Types.snd = ul }; Types.snd = (Cminor_syntax.St_goto + l') }) +| Csyntax.Scost (l, s1) -> + Obj.magic + (Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic (translate_statement vars uv ul lbls flag rettyp s1)) + (fun fgens1 s1' _ -> + Obj.magic (Errors.OK { Types.fst = fgens1; Types.snd = + (Cminor_syntax.St_cost (l, s1')) }))) + +(** val alloc_params_main : + var_types -> lenv -> Csyntax.statement -> tmpgen -> convert_flag -> + AST.typ Types.option -> (AST.ident, Csyntax.type0) Types.prod List.list + -> ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) Types.prod + Types.sig0 -> ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) + Types.prod Types.sig0 Errors.res **) +let alloc_params_main vars lbls statement uv ul rettyp params s = + Util.foldl (fun su it -> + let { Types.fst = id; Types.snd = ty } = it in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic su) + (fun eta2356 -> + let result = eta2356 in + (let { Types.fst = fgens1; Types.snd = s0 } = result in + (fun _ -> + Obj.magic + (Errors.bind2_eq (lookup' vars id) (fun t ty' _ -> + (match t with + | Global x -> + (fun _ -> Errors.Error (List.Cons ((Errors.MSG + ErrorMessages.ParamGlobalMixup), (List.Cons ((Errors.CTX + (PreIdentifiers.SymbolTag, id)), List.Nil))))) + | Stack n -> + (fun _ -> Errors.OK { Types.fst = fgens1; Types.snd = + (Cminor_syntax.St_seq ((Cminor_syntax.St_store + ((Csyntax.typ_of_type ty'), (Cminor_syntax.Cst (AST.ASTptr, + (FrontEndOps.Oaddrstack n))), (Cminor_syntax.Id + ((Csyntax.typ_of_type ty'), id)))), s0)) }) + | Local -> (fun _ -> Errors.OK result)) __)))) __))) (Errors.OK + s) params + +(** val alloc_params : + var_types -> lenv -> Csyntax.statement -> tmpgen -> convert_flag -> + AST.typ Types.option -> (AST.ident, Csyntax.type0) Types.prod List.list + -> ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) Types.prod + Types.sig0 -> ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) + Types.prod Types.sig0 Errors.res **) +let alloc_params vars lbls statement uv ul rettyp params su = + (let { Types.fst = tl; Types.snd = s0 } = Types.pi1 su in + (match s0 with + | Cminor_syntax.St_skip -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_assign (x, x0, x1) -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_store (x, x0, x1) -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_call (x, x0, x1) -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_seq (x, x0) -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_ifthenelse (x, x0, x1, x2, x3) -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_return x -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_label (x, x0) -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_goto x -> + (fun _ -> alloc_params_main vars lbls statement uv ul rettyp params su) + | Cminor_syntax.St_cost (cl, s') -> + (fun _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (alloc_params_main vars lbls statement uv ul rettyp params + { Types.fst = tl; Types.snd = s' })) (fun tls -> + Monad.m_return0 (Monad.max_def Errors.res0) { Types.fst = + (Types.pi1 tls).Types.fst; Types.snd = (Cminor_syntax.St_cost + (cl, (Types.pi1 tls).Types.snd)) }))))) __ + +(** val populate_lenv : + AST.ident List.list -> labgen -> lenv -> (lenv Types.sig0, labgen) + Types.prod Errors.res **) +let rec populate_lenv ls ul lbls = + match ls with + | List.Nil -> Errors.OK { Types.fst = lbls; Types.snd = ul } + | List.Cons (l, t) -> + (match lookup_label lbls l with + | Errors.OK x -> + (fun _ -> Errors.Error (Errors.msg ErrorMessages.DuplicateLabel)) + | Errors.Error x -> + (fun _ -> + let ret = generate_fresh_label ul in + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (populate_lenv t ret.Types.snd + (Identifiers.add PreIdentifiers.SymbolTag lbls l + ret.Types.fst))) (fun packed_lbls ul1 -> + let lbls' = packed_lbls in + Obj.magic (Errors.OK { Types.fst = lbls'; Types.snd = ul1 }))))) + __ + +(** val build_label_env : + Csyntax.statement -> (lenv Types.sig0, labgen) Types.prod Errors.res **) +let build_label_env body = + let initial_labgen = { labuniverse = + (Identifiers.new_universe PreIdentifiers.Label); label_genlist = + List.Nil } + in + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic + (populate_lenv (labels_defined body) initial_labgen + (Identifiers.empty_map PreIdentifiers.SymbolTag))) + (fun label_map u -> + let lbls = Types.pi1 label_map in + Obj.magic (Errors.OK { Types.fst = lbls; Types.snd = u }))) + +(** val translate_function : + Identifiers.universe -> ((AST.ident, AST.region) Types.prod, + Csyntax.type0) Types.prod List.list -> Csyntax.function0 -> + Cminor_syntax.internal_function Errors.res **) +let translate_function tmpuniverse globals f = + Obj.magic + (Monad.m_bind2 (Monad.max_def Errors.res0) + (Obj.magic (build_label_env f.Csyntax.fn_body)) (fun env_pack ul -> + let lbls = env_pack in + (let { Types.fst = vartypes; Types.snd = stacksize } = + characterise_vars globals f + in + (fun _ -> + let uv = { tmp_universe = tmpuniverse; tmp_env = List.Nil } in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (translate_statement vartypes uv ul lbls DoNotConvert + (Csyntax.opttyp_of_type f.Csyntax.fn_return) f.Csyntax.fn_body)) + (fun s0 -> + Monad.m_sigbind2 (Monad.max_def Errors.res0) + (Obj.magic + (alloc_params vartypes lbls f.Csyntax.fn_body uv DoNotConvert + (Csyntax.opttyp_of_type f.Csyntax.fn_return) + f.Csyntax.fn_params s0)) (fun fgens s1 _ -> + let params = + List.map (fun v -> { Types.fst = v.Types.fst; Types.snd = + (Csyntax.typ_of_type v.Types.snd) }) f.Csyntax.fn_params + in + let vars = + List.map (fun v -> { Types.fst = v.Types.fst; Types.snd = + (Csyntax.typ_of_type v.Types.snd) }) + (List.append fgens.Types.fst.tmp_env f.Csyntax.fn_vars) + in + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (Identifiers.check_distinct_env PreIdentifiers.SymbolTag + (List.append params vars))) (fun _ -> + Obj.magic (Errors.OK { Cminor_syntax.f_return = + (Csyntax.opttyp_of_type f.Csyntax.fn_return); + Cminor_syntax.f_params = params; Cminor_syntax.f_vars = vars; + Cminor_syntax.f_stacksize = stacksize; Cminor_syntax.f_body = + s1 })))))) __)) + +(** val translate_fundef : + Identifiers.universe -> ((AST.ident, AST.region) Types.prod, + Csyntax.type0) Types.prod List.list -> Csyntax.clight_fundef -> + Cminor_syntax.internal_function AST.fundef Errors.res **) +let translate_fundef tmpuniverse globals f = + (match f with + | Csyntax.CL_Internal fn -> + (fun _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_function tmpuniverse globals fn)) + (fun fn' -> Obj.magic (Errors.OK (AST.Internal fn'))))) + | Csyntax.CL_External (fn, argtys, retty) -> + (fun _ -> Errors.OK (AST.External { AST.ef_id = fn; AST.ef_sig = + (Csyntax.signature_of_type argtys retty) }))) __ + +(** val map_partial_All : + ('a1 -> __ -> 'a2 Errors.res) -> 'a1 List.list -> 'a2 List.list + Errors.res **) +let rec map_partial_All f l = + (match l with + | List.Nil -> (fun _ -> Errors.OK List.Nil) + | List.Cons (hd, tl) -> + (fun _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) (Obj.magic f hd __) + (fun b_hd -> + Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (map_partial_All f tl)) (fun b_tl -> + Obj.magic (Errors.OK (List.Cons (b_hd, b_tl)))))))) __ + +(** val clight_to_cminor : + Csyntax.clight_program -> Cminor_syntax.cminor_program Errors.res **) +let clight_to_cminor p = + let tmpuniverse = Fresh.universe_for_program p in + let fun_globals = + List.map (fun idf -> { Types.fst = { Types.fst = idf.Types.fst; + Types.snd = AST.Code }; Types.snd = + (Csyntax.type_of_fundef idf.Types.snd) }) p.AST.prog_funct + in + let var_globals = + List.map (fun v -> { Types.fst = { Types.fst = v.Types.fst.Types.fst; + Types.snd = v.Types.fst.Types.snd }; Types.snd = + v.Types.snd.Types.snd }) p.AST.prog_vars + in + let globals = List.append fun_globals var_globals in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (map_partial_All (fun x _ -> + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (translate_fundef tmpuniverse globals x.Types.snd)) + (fun f -> + Obj.magic (Errors.OK { Types.fst = x.Types.fst; Types.snd = + f })))) p.AST.prog_funct)) (fun fns -> + Obj.magic (Errors.OK { AST.prog_vars = + (List.map (fun v -> { Types.fst = v.Types.fst; Types.snd = + v.Types.snd.Types.fst }) p.AST.prog_vars); AST.prog_funct = fns; + AST.prog_main = p.AST.prog_main }))) + diff --git a/extracted/toCminor.mli b/extracted/toCminor.mli new file mode 100644 index 0000000..8fafbe1 --- /dev/null +++ b/extracted/toCminor.mli @@ -0,0 +1,536 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +open TypeComparison + +open ClassifyOp + +open Fresh + +val gather_mem_vars_addr : Csyntax.expr -> Identifiers.identifier_set + +val gather_mem_vars_expr : Csyntax.expr -> Identifiers.identifier_set + +val gather_mem_vars_ls : + Csyntax.labeled_statements -> Identifiers.identifier_set + +val gather_mem_vars_stmt : Csyntax.statement -> Identifiers.identifier_set + +type var_type = +| Global of AST.region +| Stack of Nat.nat +| Local + +val var_type_rect_Type4 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 + +val var_type_rect_Type5 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 + +val var_type_rect_Type3 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 + +val var_type_rect_Type2 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 + +val var_type_rect_Type1 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 + +val var_type_rect_Type0 : + (AST.region -> 'a1) -> (Nat.nat -> 'a1) -> 'a1 -> var_type -> 'a1 + +val var_type_inv_rect_Type4 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val var_type_inv_rect_Type3 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val var_type_inv_rect_Type2 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val var_type_inv_rect_Type1 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val var_type_inv_rect_Type0 : + var_type -> (AST.region -> __ -> 'a1) -> (Nat.nat -> __ -> 'a1) -> (__ -> + 'a1) -> 'a1 + +val var_type_discr : var_type -> var_type -> __ + +val var_type_jmdiscr : var_type -> var_type -> __ + +type var_types = + (var_type, Csyntax.type0) Types.prod Identifiers.identifier_map + +val lookup' : + var_types -> PreIdentifiers.identifier -> (var_type, Csyntax.type0) + Types.prod Errors.res + +val always_alloc : Csyntax.type0 -> Bool.bool + +val characterise_vars : + ((AST.ident, AST.region) Types.prod, Csyntax.type0) Types.prod List.list -> + Csyntax.function0 -> (var_types, Nat.nat) Types.prod + +open FrontEndVal + +open Hide + +open ByteValues + +open GenMem + +open FrontEndMem + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open Values + +open FrontEndOps + +open Cminor_syntax + +val type_should_eq : Csyntax.type0 -> Csyntax.type0 -> 'a1 -> 'a1 Errors.res + +val region_should_eq : AST.region -> AST.region -> 'a1 -> 'a1 Errors.res + +val typ_should_eq : AST.typ -> AST.typ -> 'a1 -> 'a1 Errors.res + +val translate_unop : + AST.typ -> AST.typ -> Csyntax.unary_operation -> + FrontEndOps.unary_operation Errors.res + +val fix_ptr_type : + Csyntax.type0 -> Nat.nat Types.option -> Cminor_syntax.expr -> + Cminor_syntax.expr + +val translate_add : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_sub : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_mul : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_div : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_mod : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_shr : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val complete_cmp : + Csyntax.type0 -> Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_cmp : + Integers.comparison -> Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> + Cminor_syntax.expr -> Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_misc_aop : + Csyntax.type0 -> Csyntax.type0 -> Csyntax.type0 -> (AST.intsize -> + AST.signedness -> FrontEndOps.binary_operation) -> Cminor_syntax.expr -> + Cminor_syntax.expr -> Cminor_syntax.expr Errors.res + +val translate_binop : + Csyntax.binary_operation -> Csyntax.type0 -> Cminor_syntax.expr -> + Csyntax.type0 -> Cminor_syntax.expr -> Csyntax.type0 -> Cminor_syntax.expr + Errors.res + +val translate_cast : + Csyntax.type0 -> Csyntax.type0 -> Cminor_syntax.expr Types.sig0 -> + Cminor_syntax.expr Types.sig0 Errors.res + +val cm_zero : AST.intsize -> AST.signedness -> Cminor_syntax.expr + +val cm_one : AST.intsize -> AST.signedness -> Cminor_syntax.expr + +val translate_addr : + var_types -> Csyntax.expr -> Cminor_syntax.expr Types.sig0 Errors.res + +val translate_expr : + var_types -> Csyntax.expr -> Cminor_syntax.expr Types.sig0 Errors.res + +type destination = +| IdDest of AST.ident +| MemDest of Cminor_syntax.expr Types.sig0 + +val destination_rect_Type4 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 + +val destination_rect_Type5 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 + +val destination_rect_Type3 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 + +val destination_rect_Type2 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 + +val destination_rect_Type1 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 + +val destination_rect_Type0 : + var_types -> AST.typ -> (AST.ident -> __ -> 'a1) -> (Cminor_syntax.expr + Types.sig0 -> 'a1) -> destination -> 'a1 + +val destination_inv_rect_Type4 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 + +val destination_inv_rect_Type3 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 + +val destination_inv_rect_Type2 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 + +val destination_inv_rect_Type1 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 + +val destination_inv_rect_Type0 : + var_types -> AST.typ -> destination -> (AST.ident -> __ -> __ -> 'a1) -> + (Cminor_syntax.expr Types.sig0 -> __ -> 'a1) -> 'a1 + +val destination_discr : + var_types -> AST.typ -> destination -> destination -> __ + +val destination_jmdiscr : + var_types -> AST.typ -> destination -> destination -> __ + +val translate_dest : var_types -> Csyntax.expr -> destination Errors.res + +type lenv = PreIdentifiers.identifier Identifiers.identifier_map + +val lookup_label : + lenv -> PreIdentifiers.identifier -> PreIdentifiers.identifier Errors.res + +type labgen = { labuniverse : Identifiers.universe; + label_genlist : PreIdentifiers.identifier List.list } + +val labgen_rect_Type4 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> 'a1) + -> labgen -> 'a1 + +val labgen_rect_Type5 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> 'a1) + -> labgen -> 'a1 + +val labgen_rect_Type3 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> 'a1) + -> labgen -> 'a1 + +val labgen_rect_Type2 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> 'a1) + -> labgen -> 'a1 + +val labgen_rect_Type1 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> 'a1) + -> labgen -> 'a1 + +val labgen_rect_Type0 : + (Identifiers.universe -> PreIdentifiers.identifier List.list -> __ -> 'a1) + -> labgen -> 'a1 + +val labuniverse : labgen -> Identifiers.universe + +val label_genlist : labgen -> PreIdentifiers.identifier List.list + +val labgen_inv_rect_Type4 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 + +val labgen_inv_rect_Type3 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 + +val labgen_inv_rect_Type2 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 + +val labgen_inv_rect_Type1 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 + +val labgen_inv_rect_Type0 : + labgen -> (Identifiers.universe -> PreIdentifiers.identifier List.list -> + __ -> __ -> 'a1) -> 'a1 + +val labgen_discr : labgen -> labgen -> __ + +val labgen_jmdiscr : labgen -> labgen -> __ + +val generate_fresh_label : + labgen -> (PreIdentifiers.identifier, labgen) Types.prod Types.sig0 + +val labels_defined_switch : Csyntax.labeled_statements -> AST.ident List.list + +val labels_defined : Csyntax.statement -> AST.ident List.list + +val m_option_map : + ('a1 -> 'a2 Errors.res) -> 'a1 Types.option -> 'a2 Types.option Errors.res + +val translate_expr_sigma : + var_types -> Csyntax.expr -> (AST.typ, Cminor_syntax.expr) Types.dPair + Types.sig0 Errors.res + +val add_tmps : + var_types -> (AST.ident, Csyntax.type0) Types.prod List.list -> var_types + +type tmpgen = { tmp_universe : Identifiers.universe; + tmp_env : (AST.ident, Csyntax.type0) Types.prod List.list } + +val tmpgen_rect_Type4 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) Types.prod + List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 + +val tmpgen_rect_Type5 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) Types.prod + List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 + +val tmpgen_rect_Type3 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) Types.prod + List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 + +val tmpgen_rect_Type2 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) Types.prod + List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 + +val tmpgen_rect_Type1 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) Types.prod + List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 + +val tmpgen_rect_Type0 : + var_types -> (Identifiers.universe -> (AST.ident, Csyntax.type0) Types.prod + List.list -> __ -> __ -> 'a1) -> tmpgen -> 'a1 + +val tmp_universe : var_types -> tmpgen -> Identifiers.universe + +val tmp_env : + var_types -> tmpgen -> (AST.ident, Csyntax.type0) Types.prod List.list + +val tmpgen_inv_rect_Type4 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 + +val tmpgen_inv_rect_Type3 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 + +val tmpgen_inv_rect_Type2 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 + +val tmpgen_inv_rect_Type1 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 + +val tmpgen_inv_rect_Type0 : + var_types -> tmpgen -> (Identifiers.universe -> (AST.ident, Csyntax.type0) + Types.prod List.list -> __ -> __ -> __ -> 'a1) -> 'a1 + +val tmpgen_discr : var_types -> tmpgen -> tmpgen -> __ + +val tmpgen_jmdiscr : var_types -> tmpgen -> tmpgen -> __ + +val alloc_tmp : + var_types -> Csyntax.type0 -> tmpgen -> (AST.ident, tmpgen) Types.prod + +val mklabels : + labgen -> ((PreIdentifiers.identifier, PreIdentifiers.identifier) + Types.prod, labgen) Types.prod + +type convert_flag = +| DoNotConvert +| ConvertTo of PreIdentifiers.identifier * PreIdentifiers.identifier + +val convert_flag_rect_Type4 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 + +val convert_flag_rect_Type5 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 + +val convert_flag_rect_Type3 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 + +val convert_flag_rect_Type2 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 + +val convert_flag_rect_Type1 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 + +val convert_flag_rect_Type0 : + 'a1 -> (PreIdentifiers.identifier -> PreIdentifiers.identifier -> 'a1) -> + convert_flag -> 'a1 + +val convert_flag_inv_rect_Type4 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 + +val convert_flag_inv_rect_Type3 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 + +val convert_flag_inv_rect_Type2 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 + +val convert_flag_inv_rect_Type1 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 + +val convert_flag_inv_rect_Type0 : + convert_flag -> (__ -> 'a1) -> (PreIdentifiers.identifier -> + PreIdentifiers.identifier -> __ -> 'a1) -> 'a1 + +val convert_flag_discr : convert_flag -> convert_flag -> __ + +val convert_flag_jmdiscr : convert_flag -> convert_flag -> __ + +val labels_of_flag : convert_flag -> PreIdentifiers.identifier List.list + +val translate_statement : + var_types -> tmpgen -> labgen -> lenv -> convert_flag -> AST.typ + Types.option -> Csyntax.statement -> ((tmpgen, labgen) Types.prod, + Cminor_syntax.stmt) Types.prod Types.sig0 Errors.res + +val alloc_params_main : + var_types -> lenv -> Csyntax.statement -> tmpgen -> convert_flag -> AST.typ + Types.option -> (AST.ident, Csyntax.type0) Types.prod List.list -> + ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) Types.prod Types.sig0 -> + ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) Types.prod Types.sig0 + Errors.res + +val alloc_params : + var_types -> lenv -> Csyntax.statement -> tmpgen -> convert_flag -> AST.typ + Types.option -> (AST.ident, Csyntax.type0) Types.prod List.list -> + ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) Types.prod Types.sig0 -> + ((tmpgen, labgen) Types.prod, Cminor_syntax.stmt) Types.prod Types.sig0 + Errors.res + +val populate_lenv : + AST.ident List.list -> labgen -> lenv -> (lenv Types.sig0, labgen) + Types.prod Errors.res + +val build_label_env : + Csyntax.statement -> (lenv Types.sig0, labgen) Types.prod Errors.res + +val translate_function : + Identifiers.universe -> ((AST.ident, AST.region) Types.prod, Csyntax.type0) + Types.prod List.list -> Csyntax.function0 -> + Cminor_syntax.internal_function Errors.res + +val translate_fundef : + Identifiers.universe -> ((AST.ident, AST.region) Types.prod, Csyntax.type0) + Types.prod List.list -> Csyntax.clight_fundef -> + Cminor_syntax.internal_function AST.fundef Errors.res + +val map_partial_All : + ('a1 -> __ -> 'a2 Errors.res) -> 'a1 List.list -> 'a2 List.list Errors.res + +val clight_to_cminor : + Csyntax.clight_program -> Cminor_syntax.cminor_program Errors.res + diff --git a/extracted/toRTLabs.ml b/extracted/toRTLabs.ml new file mode 100644 index 0000000..c33d803 --- /dev/null +++ b/extracted/toRTLabs.ml @@ -0,0 +1,1409 @@ +open Preamble + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Lists + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Positive + +open PreIdentifiers + +open Errors + +open Globalenvs + +open CostLabel + +open FrontEndOps + +open Cminor_syntax + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open RTLabs_syntax + +type env = + (Registers.register, AST.typ) Types.prod Identifiers.identifier_map + +(** val populate_env : + env -> Identifiers.universe -> (AST.ident, AST.typ) Types.prod List.list + -> (((Registers.register, AST.typ) Types.prod List.list, env) Types.prod, + Identifiers.universe) Types.prod **) +let populate_env en gen = + List.foldr (fun idt rsengen -> + let { Types.fst = id; Types.snd = ty } = idt in + let { Types.fst = eta2859; Types.snd = gen0 } = rsengen in + let { Types.fst = rs; Types.snd = en0 } = eta2859 in + let { Types.fst = r; Types.snd = gen' } = + Identifiers.fresh PreIdentifiers.RegisterTag gen0 + in + { Types.fst = { Types.fst = (List.Cons ({ Types.fst = r; Types.snd = + ty }, rs)); Types.snd = + (Identifiers.add PreIdentifiers.SymbolTag en0 id { Types.fst = r; + Types.snd = ty }) }; Types.snd = gen' }) { Types.fst = { Types.fst = + List.Nil; Types.snd = en }; Types.snd = gen } + +(** val lookup_reg : env -> AST.ident -> AST.typ -> Registers.register **) +let lookup_reg e id ty = + (Identifiers.lookup_present PreIdentifiers.SymbolTag e id).Types.fst + +type fixed = { fx_gotos : Identifiers.identifier_set; fx_env : env; + fx_rettyp : AST.typ Types.option } + +(** val fixed_rect_Type4 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> + fixed -> 'a1 **) +let rec fixed_rect_Type4 h_mk_fixed x_15483 = + let { fx_gotos = fx_gotos0; fx_env = fx_env0; fx_rettyp = fx_rettyp0 } = + x_15483 + in + h_mk_fixed fx_gotos0 fx_env0 fx_rettyp0 + +(** val fixed_rect_Type5 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> + fixed -> 'a1 **) +let rec fixed_rect_Type5 h_mk_fixed x_15485 = + let { fx_gotos = fx_gotos0; fx_env = fx_env0; fx_rettyp = fx_rettyp0 } = + x_15485 + in + h_mk_fixed fx_gotos0 fx_env0 fx_rettyp0 + +(** val fixed_rect_Type3 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> + fixed -> 'a1 **) +let rec fixed_rect_Type3 h_mk_fixed x_15487 = + let { fx_gotos = fx_gotos0; fx_env = fx_env0; fx_rettyp = fx_rettyp0 } = + x_15487 + in + h_mk_fixed fx_gotos0 fx_env0 fx_rettyp0 + +(** val fixed_rect_Type2 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> + fixed -> 'a1 **) +let rec fixed_rect_Type2 h_mk_fixed x_15489 = + let { fx_gotos = fx_gotos0; fx_env = fx_env0; fx_rettyp = fx_rettyp0 } = + x_15489 + in + h_mk_fixed fx_gotos0 fx_env0 fx_rettyp0 + +(** val fixed_rect_Type1 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> + fixed -> 'a1 **) +let rec fixed_rect_Type1 h_mk_fixed x_15491 = + let { fx_gotos = fx_gotos0; fx_env = fx_env0; fx_rettyp = fx_rettyp0 } = + x_15491 + in + h_mk_fixed fx_gotos0 fx_env0 fx_rettyp0 + +(** val fixed_rect_Type0 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> + fixed -> 'a1 **) +let rec fixed_rect_Type0 h_mk_fixed x_15493 = + let { fx_gotos = fx_gotos0; fx_env = fx_env0; fx_rettyp = fx_rettyp0 } = + x_15493 + in + h_mk_fixed fx_gotos0 fx_env0 fx_rettyp0 + +(** val fx_gotos : fixed -> Identifiers.identifier_set **) +let rec fx_gotos xxx = + xxx.fx_gotos + +(** val fx_env : fixed -> env **) +let rec fx_env xxx = + xxx.fx_env + +(** val fx_rettyp : fixed -> AST.typ Types.option **) +let rec fx_rettyp xxx = + xxx.fx_rettyp + +(** val fixed_inv_rect_Type4 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 **) +let fixed_inv_rect_Type4 hterm h1 = + let hcut = fixed_rect_Type4 h1 hterm in hcut __ + +(** val fixed_inv_rect_Type3 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 **) +let fixed_inv_rect_Type3 hterm h1 = + let hcut = fixed_rect_Type3 h1 hterm in hcut __ + +(** val fixed_inv_rect_Type2 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 **) +let fixed_inv_rect_Type2 hterm h1 = + let hcut = fixed_rect_Type2 h1 hterm in hcut __ + +(** val fixed_inv_rect_Type1 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 **) +let fixed_inv_rect_Type1 hterm h1 = + let hcut = fixed_rect_Type1 h1 hterm in hcut __ + +(** val fixed_inv_rect_Type0 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 **) +let fixed_inv_rect_Type0 hterm h1 = + let hcut = fixed_rect_Type0 h1 hterm in hcut __ + +(** val fixed_discr : fixed -> fixed -> __ **) +let fixed_discr x y = + Logic.eq_rect_Type2 x + (let { fx_gotos = a0; fx_env = a1; fx_rettyp = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val fixed_jmdiscr : fixed -> fixed -> __ **) +let fixed_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { fx_gotos = a0; fx_env = a1; fx_rettyp = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +type resultok = __ + +type goto_map = + PreIdentifiers.identifier Identifiers.identifier_map + (* singleton inductive, whose constructor was mk_goto_map *) + +(** val goto_map_rect_Type4 : + fixed -> RTLabs_syntax.statement Graphs.graph -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> 'a1) + -> goto_map -> 'a1 **) +let rec goto_map_rect_Type4 fx g h_mk_goto_map x_15509 = + let gm_map = x_15509 in h_mk_goto_map gm_map __ __ + +(** val goto_map_rect_Type5 : + fixed -> RTLabs_syntax.statement Graphs.graph -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> 'a1) + -> goto_map -> 'a1 **) +let rec goto_map_rect_Type5 fx g h_mk_goto_map x_15511 = + let gm_map = x_15511 in h_mk_goto_map gm_map __ __ + +(** val goto_map_rect_Type3 : + fixed -> RTLabs_syntax.statement Graphs.graph -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> 'a1) + -> goto_map -> 'a1 **) +let rec goto_map_rect_Type3 fx g h_mk_goto_map x_15513 = + let gm_map = x_15513 in h_mk_goto_map gm_map __ __ + +(** val goto_map_rect_Type2 : + fixed -> RTLabs_syntax.statement Graphs.graph -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> 'a1) + -> goto_map -> 'a1 **) +let rec goto_map_rect_Type2 fx g h_mk_goto_map x_15515 = + let gm_map = x_15515 in h_mk_goto_map gm_map __ __ + +(** val goto_map_rect_Type1 : + fixed -> RTLabs_syntax.statement Graphs.graph -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> 'a1) + -> goto_map -> 'a1 **) +let rec goto_map_rect_Type1 fx g h_mk_goto_map x_15517 = + let gm_map = x_15517 in h_mk_goto_map gm_map __ __ + +(** val goto_map_rect_Type0 : + fixed -> RTLabs_syntax.statement Graphs.graph -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> 'a1) + -> goto_map -> 'a1 **) +let rec goto_map_rect_Type0 fx g h_mk_goto_map x_15519 = + let gm_map = x_15519 in h_mk_goto_map gm_map __ __ + +(** val gm_map : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map **) +let rec gm_map fx g xxx = + let yyy = xxx in yyy + +(** val goto_map_inv_rect_Type4 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let goto_map_inv_rect_Type4 x1 x2 hterm h1 = + let hcut = goto_map_rect_Type4 x1 x2 h1 hterm in hcut __ + +(** val goto_map_inv_rect_Type3 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let goto_map_inv_rect_Type3 x1 x2 hterm h1 = + let hcut = goto_map_rect_Type3 x1 x2 h1 hterm in hcut __ + +(** val goto_map_inv_rect_Type2 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let goto_map_inv_rect_Type2 x1 x2 hterm h1 = + let hcut = goto_map_rect_Type2 x1 x2 h1 hterm in hcut __ + +(** val goto_map_inv_rect_Type1 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let goto_map_inv_rect_Type1 x1 x2 hterm h1 = + let hcut = goto_map_rect_Type1 x1 x2 h1 hterm in hcut __ + +(** val goto_map_inv_rect_Type0 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ + -> 'a1) -> 'a1 **) +let goto_map_inv_rect_Type0 x1 x2 hterm h1 = + let hcut = goto_map_rect_Type0 x1 x2 h1 hterm in hcut __ + +(** val goto_map_discr : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> goto_map -> + __ **) +let goto_map_discr a1 a2 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val goto_map_jmdiscr : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> goto_map -> + __ **) +let goto_map_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val dpi1__o__gm_map__o__inject : + fixed -> RTLabs_syntax.statement Graphs.graph -> (goto_map, 'a1) + Types.dPair -> PreIdentifiers.identifier Identifiers.identifier_map + Types.sig0 **) +let dpi1__o__gm_map__o__inject x1 x2 x4 = + gm_map x1 x2 x4.Types.dpi1 + +(** val eject__o__gm_map__o__inject : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map Types.sig0 -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 **) +let eject__o__gm_map__o__inject x1 x2 x4 = + gm_map x1 x2 (Types.pi1 x4) + +(** val gm_map__o__inject : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 **) +let gm_map__o__inject x1 x2 x3 = + gm_map x1 x2 x3 + +(** val dpi1__o__gm_map : + fixed -> RTLabs_syntax.statement Graphs.graph -> (goto_map, 'a1) + Types.dPair -> PreIdentifiers.identifier Identifiers.identifier_map **) +let dpi1__o__gm_map x0 x1 x3 = + gm_map x0 x1 x3.Types.dpi1 + +(** val eject__o__gm_map : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map Types.sig0 -> + PreIdentifiers.identifier Identifiers.identifier_map **) +let eject__o__gm_map x0 x1 x3 = + gm_map x0 x1 (Types.pi1 x3) + +type partial_fn = { pf_labgen : Identifiers.universe; + pf_reggen : Identifiers.universe; + pf_params : (Registers.register, AST.typ) Types.prod + List.list; + pf_locals : (Registers.register, AST.typ) Types.prod + List.list; pf_result : resultok; + pf_stacksize : Nat.nat; + pf_graph : RTLabs_syntax.statement Graphs.graph; + pf_gotos : goto_map; + pf_labels : PreIdentifiers.identifier + Identifiers.identifier_map Types.sig0; + pf_entry : Graphs.label Types.sig0; + pf_exit : Graphs.label Types.sig0 } + +(** val partial_fn_rect_Type4 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 **) +let rec partial_fn_rect_Type4 fx h_mk_partial_fn x_15537 = + let { pf_labgen = pf_labgen0; pf_reggen = pf_reggen0; pf_params = + pf_params0; pf_locals = pf_locals0; pf_result = pf_result0; + pf_stacksize = pf_stacksize0; pf_graph = pf_graph0; pf_gotos = pf_gotos0; + pf_labels = pf_labels0; pf_entry = pf_entry0; pf_exit = pf_exit0 } = + x_15537 + in + h_mk_partial_fn pf_labgen0 pf_reggen0 pf_params0 pf_locals0 pf_result0 __ + pf_stacksize0 pf_graph0 __ pf_gotos0 pf_labels0 __ pf_entry0 pf_exit0 __ + +(** val partial_fn_rect_Type5 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 **) +let rec partial_fn_rect_Type5 fx h_mk_partial_fn x_15539 = + let { pf_labgen = pf_labgen0; pf_reggen = pf_reggen0; pf_params = + pf_params0; pf_locals = pf_locals0; pf_result = pf_result0; + pf_stacksize = pf_stacksize0; pf_graph = pf_graph0; pf_gotos = pf_gotos0; + pf_labels = pf_labels0; pf_entry = pf_entry0; pf_exit = pf_exit0 } = + x_15539 + in + h_mk_partial_fn pf_labgen0 pf_reggen0 pf_params0 pf_locals0 pf_result0 __ + pf_stacksize0 pf_graph0 __ pf_gotos0 pf_labels0 __ pf_entry0 pf_exit0 __ + +(** val partial_fn_rect_Type3 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 **) +let rec partial_fn_rect_Type3 fx h_mk_partial_fn x_15541 = + let { pf_labgen = pf_labgen0; pf_reggen = pf_reggen0; pf_params = + pf_params0; pf_locals = pf_locals0; pf_result = pf_result0; + pf_stacksize = pf_stacksize0; pf_graph = pf_graph0; pf_gotos = pf_gotos0; + pf_labels = pf_labels0; pf_entry = pf_entry0; pf_exit = pf_exit0 } = + x_15541 + in + h_mk_partial_fn pf_labgen0 pf_reggen0 pf_params0 pf_locals0 pf_result0 __ + pf_stacksize0 pf_graph0 __ pf_gotos0 pf_labels0 __ pf_entry0 pf_exit0 __ + +(** val partial_fn_rect_Type2 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 **) +let rec partial_fn_rect_Type2 fx h_mk_partial_fn x_15543 = + let { pf_labgen = pf_labgen0; pf_reggen = pf_reggen0; pf_params = + pf_params0; pf_locals = pf_locals0; pf_result = pf_result0; + pf_stacksize = pf_stacksize0; pf_graph = pf_graph0; pf_gotos = pf_gotos0; + pf_labels = pf_labels0; pf_entry = pf_entry0; pf_exit = pf_exit0 } = + x_15543 + in + h_mk_partial_fn pf_labgen0 pf_reggen0 pf_params0 pf_locals0 pf_result0 __ + pf_stacksize0 pf_graph0 __ pf_gotos0 pf_labels0 __ pf_entry0 pf_exit0 __ + +(** val partial_fn_rect_Type1 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 **) +let rec partial_fn_rect_Type1 fx h_mk_partial_fn x_15545 = + let { pf_labgen = pf_labgen0; pf_reggen = pf_reggen0; pf_params = + pf_params0; pf_locals = pf_locals0; pf_result = pf_result0; + pf_stacksize = pf_stacksize0; pf_graph = pf_graph0; pf_gotos = pf_gotos0; + pf_labels = pf_labels0; pf_entry = pf_entry0; pf_exit = pf_exit0 } = + x_15545 + in + h_mk_partial_fn pf_labgen0 pf_reggen0 pf_params0 pf_locals0 pf_result0 __ + pf_stacksize0 pf_graph0 __ pf_gotos0 pf_labels0 __ pf_entry0 pf_exit0 __ + +(** val partial_fn_rect_Type0 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 **) +let rec partial_fn_rect_Type0 fx h_mk_partial_fn x_15547 = + let { pf_labgen = pf_labgen0; pf_reggen = pf_reggen0; pf_params = + pf_params0; pf_locals = pf_locals0; pf_result = pf_result0; + pf_stacksize = pf_stacksize0; pf_graph = pf_graph0; pf_gotos = pf_gotos0; + pf_labels = pf_labels0; pf_entry = pf_entry0; pf_exit = pf_exit0 } = + x_15547 + in + h_mk_partial_fn pf_labgen0 pf_reggen0 pf_params0 pf_locals0 pf_result0 __ + pf_stacksize0 pf_graph0 __ pf_gotos0 pf_labels0 __ pf_entry0 pf_exit0 __ + +(** val pf_labgen : fixed -> partial_fn -> Identifiers.universe **) +let rec pf_labgen fx xxx = + xxx.pf_labgen + +(** val pf_reggen : fixed -> partial_fn -> Identifiers.universe **) +let rec pf_reggen fx xxx = + xxx.pf_reggen + +(** val pf_params : + fixed -> partial_fn -> (Registers.register, AST.typ) Types.prod List.list **) +let rec pf_params fx xxx = + xxx.pf_params + +(** val pf_locals : + fixed -> partial_fn -> (Registers.register, AST.typ) Types.prod List.list **) +let rec pf_locals fx xxx = + xxx.pf_locals + +(** val pf_result : fixed -> partial_fn -> resultok **) +let rec pf_result fx xxx = + xxx.pf_result + +(** val pf_stacksize : fixed -> partial_fn -> Nat.nat **) +let rec pf_stacksize fx xxx = + xxx.pf_stacksize + +(** val pf_graph : + fixed -> partial_fn -> RTLabs_syntax.statement Graphs.graph **) +let rec pf_graph fx xxx = + xxx.pf_graph + +(** val pf_gotos : fixed -> partial_fn -> goto_map **) +let rec pf_gotos fx xxx = + xxx.pf_gotos + +(** val pf_labels : + fixed -> partial_fn -> PreIdentifiers.identifier + Identifiers.identifier_map Types.sig0 **) +let rec pf_labels fx xxx = + xxx.pf_labels + +(** val pf_entry : fixed -> partial_fn -> Graphs.label Types.sig0 **) +let rec pf_entry fx xxx = + xxx.pf_entry + +(** val pf_exit : fixed -> partial_fn -> Graphs.label Types.sig0 **) +let rec pf_exit fx xxx = + xxx.pf_exit + +(** val partial_fn_inv_rect_Type4 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 **) +let partial_fn_inv_rect_Type4 x1 hterm h1 = + let hcut = partial_fn_rect_Type4 x1 h1 hterm in hcut __ + +(** val partial_fn_inv_rect_Type3 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 **) +let partial_fn_inv_rect_Type3 x1 hterm h1 = + let hcut = partial_fn_rect_Type3 x1 h1 hterm in hcut __ + +(** val partial_fn_inv_rect_Type2 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 **) +let partial_fn_inv_rect_Type2 x1 hterm h1 = + let hcut = partial_fn_rect_Type2 x1 h1 hterm in hcut __ + +(** val partial_fn_inv_rect_Type1 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 **) +let partial_fn_inv_rect_Type1 x1 hterm h1 = + let hcut = partial_fn_rect_Type1 x1 h1 hterm in hcut __ + +(** val partial_fn_inv_rect_Type0 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> + (Registers.register, AST.typ) Types.prod List.list -> resultok -> __ -> + Nat.nat -> RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 **) +let partial_fn_inv_rect_Type0 x1 hterm h1 = + let hcut = partial_fn_rect_Type0 x1 h1 hterm in hcut __ + +(** val partial_fn_jmdiscr : fixed -> partial_fn -> partial_fn -> __ **) +let partial_fn_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { pf_labgen = a0; pf_reggen = a10; pf_params = a2; pf_locals = a3; + pf_result = a4; pf_stacksize = a6; pf_graph = a7; pf_gotos = a9; + pf_labels = a100; pf_entry = a12; pf_exit = a13 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __ __ __ __ __)) + y + +(** val fn_contains_rect_Type4 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec fn_contains_rect_Type4 fx f1 f2 h_mk_fn_contains = + h_mk_fn_contains __ __ __ + +(** val fn_contains_rect_Type5 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec fn_contains_rect_Type5 fx f1 f2 h_mk_fn_contains = + h_mk_fn_contains __ __ __ + +(** val fn_contains_rect_Type3 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec fn_contains_rect_Type3 fx f1 f2 h_mk_fn_contains = + h_mk_fn_contains __ __ __ + +(** val fn_contains_rect_Type2 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec fn_contains_rect_Type2 fx f1 f2 h_mk_fn_contains = + h_mk_fn_contains __ __ __ + +(** val fn_contains_rect_Type1 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec fn_contains_rect_Type1 fx f1 f2 h_mk_fn_contains = + h_mk_fn_contains __ __ __ + +(** val fn_contains_rect_Type0 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec fn_contains_rect_Type0 fx f1 f2 h_mk_fn_contains = + h_mk_fn_contains __ __ __ + +(** val fn_contains_inv_rect_Type4 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let fn_contains_inv_rect_Type4 x1 x2 x3 h1 = + let hcut = fn_contains_rect_Type4 x1 x2 x3 h1 in hcut __ + +(** val fn_contains_inv_rect_Type3 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let fn_contains_inv_rect_Type3 x1 x2 x3 h1 = + let hcut = fn_contains_rect_Type3 x1 x2 x3 h1 in hcut __ + +(** val fn_contains_inv_rect_Type2 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let fn_contains_inv_rect_Type2 x1 x2 x3 h1 = + let hcut = fn_contains_rect_Type2 x1 x2 x3 h1 in hcut __ + +(** val fn_contains_inv_rect_Type1 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let fn_contains_inv_rect_Type1 x1 x2 x3 h1 = + let hcut = fn_contains_rect_Type1 x1 x2 x3 h1 in hcut __ + +(** val fn_contains_inv_rect_Type0 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let fn_contains_inv_rect_Type0 x1 x2 x3 h1 = + let hcut = fn_contains_rect_Type0 x1 x2 x3 h1 in hcut __ + +(** val fn_contains_discr : fixed -> partial_fn -> partial_fn -> __ **) +let fn_contains_discr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val fn_contains_jmdiscr : fixed -> partial_fn -> partial_fn -> __ **) +let fn_contains_jmdiscr a1 a2 a3 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val fill_in_statement : + fixed -> Graphs.label -> RTLabs_syntax.statement -> partial_fn -> + partial_fn Types.sig0 **) +let fill_in_statement fx l s f = + { pf_labgen = f.pf_labgen; pf_reggen = f.pf_reggen; pf_params = + f.pf_params; pf_locals = f.pf_locals; pf_result = f.pf_result; + pf_stacksize = f.pf_stacksize; pf_graph = + (Identifiers.add PreIdentifiers.LabelTag f.pf_graph l s); pf_gotos = + (gm_map fx f.pf_graph f.pf_gotos); pf_labels = (Types.pi1 f.pf_labels); + pf_entry = (Types.pi1 f.pf_entry); pf_exit = (Types.pi1 f.pf_exit) } + +(** val add_to_graph : + fixed -> Graphs.label -> RTLabs_syntax.statement -> partial_fn -> + partial_fn Types.sig0 **) +let add_to_graph fx l s f = + { pf_labgen = f.pf_labgen; pf_reggen = f.pf_reggen; pf_params = + f.pf_params; pf_locals = f.pf_locals; pf_result = f.pf_result; + pf_stacksize = f.pf_stacksize; pf_graph = + (Identifiers.add PreIdentifiers.LabelTag f.pf_graph l s); pf_gotos = + (let m = f.pf_gotos in m); pf_labels = (let m = f.pf_labels in m); + pf_entry = l; pf_exit = (Types.pi1 f.pf_exit) } + +(** val change_entry : + fixed -> partial_fn -> PreIdentifiers.identifier -> partial_fn Types.sig0 **) +let change_entry fx f l = + { pf_labgen = f.pf_labgen; pf_reggen = f.pf_reggen; pf_params = + f.pf_params; pf_locals = f.pf_locals; pf_result = f.pf_result; + pf_stacksize = f.pf_stacksize; pf_graph = f.pf_graph; pf_gotos = + f.pf_gotos; pf_labels = f.pf_labels; pf_entry = l; pf_exit = f.pf_exit } + +(** val add_fresh_to_graph : + fixed -> (Graphs.label -> RTLabs_syntax.statement) -> partial_fn -> + partial_fn Types.sig0 **) +let add_fresh_to_graph fx s f = + (let { Types.fst = l; Types.snd = g } = + Identifiers.fresh PreIdentifiers.LabelTag f.pf_labgen + in + (fun _ -> + let s1 = s (Types.pi1 f.pf_entry) in + { pf_labgen = g; pf_reggen = f.pf_reggen; pf_params = f.pf_params; + pf_locals = f.pf_locals; pf_result = f.pf_result; pf_stacksize = + f.pf_stacksize; pf_graph = + (Identifiers.add PreIdentifiers.LabelTag f.pf_graph l s1); pf_gotos = + (let m = f.pf_gotos in m); pf_labels = (let m = f.pf_labels in m); + pf_entry = l; pf_exit = (Types.pi1 f.pf_exit) })) __ + +(** val fresh_reg : + fixed -> partial_fn -> AST.typ -> (partial_fn Types.sig0, + Registers.register Types.sig0) Types.dPair **) +let fresh_reg fx f ty = + let { Types.fst = r; Types.snd = g } = + Identifiers.fresh PreIdentifiers.RegisterTag f.pf_reggen + in + let f' = { pf_labgen = f.pf_labgen; pf_reggen = g; pf_params = f.pf_params; + pf_locals = (List.Cons ({ Types.fst = r; Types.snd = ty }, f.pf_locals)); + pf_result = + ((match fx.fx_rettyp with + | Types.None -> Obj.magic __ + | Types.Some t -> + (fun clearme -> let r' = Obj.magic clearme in Obj.magic r')) + f.pf_result); pf_stacksize = f.pf_stacksize; pf_graph = f.pf_graph; + pf_gotos = f.pf_gotos; pf_labels = f.pf_labels; pf_entry = f.pf_entry; + pf_exit = f.pf_exit } + in + { Types.dpi1 = f'; Types.dpi2 = r } + +(** val choose_reg : + fixed -> AST.typ -> Cminor_syntax.expr -> partial_fn -> (partial_fn + Types.sig0, Registers.register Types.sig0) Types.dPair **) +let choose_reg fx ty e f = + (match e with + | Cminor_syntax.Id (t, i) -> + (fun _ -> { Types.dpi1 = f; Types.dpi2 = (lookup_reg fx.fx_env i t) }) + | Cminor_syntax.Cst (x, x0) -> (fun _ -> fresh_reg fx f x) + | Cminor_syntax.Op1 (x, x0, x1, x2) -> (fun _ -> fresh_reg fx f x0) + | Cminor_syntax.Op2 (x, x0, x1, x2, x3, x4) -> + (fun _ -> fresh_reg fx f x1) + | Cminor_syntax.Mem (x, x0) -> (fun _ -> fresh_reg fx f x) + | Cminor_syntax.Cond (x, x0, x1, x2, x3, x4) -> + (fun _ -> fresh_reg fx f x1) + | Cminor_syntax.Ecost (x, x0, x1) -> (fun _ -> fresh_reg fx f x)) __ + +(** val foldr_all : + ('a1 -> __ -> 'a2 -> 'a2) -> 'a2 -> 'a1 List.list -> 'a2 **) +let rec foldr_all f b l = + (match l with + | List.Nil -> (fun _ -> b) + | List.Cons (a, l0) -> (fun _ -> f a __ (foldr_all f b l0))) __ + +(** val foldr_all' : + ('a1 -> __ -> 'a1 List.list -> 'a2 -> 'a2) -> 'a2 -> 'a1 List.list -> 'a2 **) +let rec foldr_all' f b l = + (match l with + | List.Nil -> (fun _ -> b) + | List.Cons (a, l0) -> (fun _ -> f a __ l0 (foldr_all' f b l0))) __ + +(** val eject' : ('a1, 'a2) Types.dPair -> 'a1 **) +let eject' x = + x.Types.dpi1 + +(** val choose_regs : + fixed -> (AST.typ, Cminor_syntax.expr) Types.dPair List.list -> + partial_fn -> (partial_fn Types.sig0, Registers.register List.list + Types.sig0) Types.dPair **) +let choose_regs fx es f = + foldr_all' (fun e _ tl acc -> + let { Types.dpi1 = f1; Types.dpi2 = rs } = acc in + (let { Types.dpi1 = t; Types.dpi2 = e0 } = e in + (fun _ -> + let { Types.dpi1 = f'; Types.dpi2 = r } = + choose_reg fx t e0 (Types.pi1 f1) + in + { Types.dpi1 = (Types.pi1 f'); Types.dpi2 = (List.Cons ((Types.pi1 r), + (Types.pi1 rs))) })) __) { Types.dpi1 = f; Types.dpi2 = List.Nil } es + +(** val add_stmt_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 **) +let rec add_stmt_inv_rect_Type4 fx s f f' h_mk_add_stmt_inv = + h_mk_add_stmt_inv __ __ + +(** val add_stmt_inv_rect_Type5 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 **) +let rec add_stmt_inv_rect_Type5 fx s f f' h_mk_add_stmt_inv = + h_mk_add_stmt_inv __ __ + +(** val add_stmt_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 **) +let rec add_stmt_inv_rect_Type3 fx s f f' h_mk_add_stmt_inv = + h_mk_add_stmt_inv __ __ + +(** val add_stmt_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 **) +let rec add_stmt_inv_rect_Type2 fx s f f' h_mk_add_stmt_inv = + h_mk_add_stmt_inv __ __ + +(** val add_stmt_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 **) +let rec add_stmt_inv_rect_Type1 fx s f f' h_mk_add_stmt_inv = + h_mk_add_stmt_inv __ __ + +(** val add_stmt_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 **) +let rec add_stmt_inv_rect_Type0 fx s f f' h_mk_add_stmt_inv = + h_mk_add_stmt_inv __ __ + +(** val add_stmt_inv_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + __ -> 'a1) -> 'a1 **) +let add_stmt_inv_inv_rect_Type4 x1 x2 x3 x4 h1 = + let hcut = add_stmt_inv_rect_Type4 x1 x2 x3 x4 h1 in hcut __ + +(** val add_stmt_inv_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + __ -> 'a1) -> 'a1 **) +let add_stmt_inv_inv_rect_Type3 x1 x2 x3 x4 h1 = + let hcut = add_stmt_inv_rect_Type3 x1 x2 x3 x4 h1 in hcut __ + +(** val add_stmt_inv_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + __ -> 'a1) -> 'a1 **) +let add_stmt_inv_inv_rect_Type2 x1 x2 x3 x4 h1 = + let hcut = add_stmt_inv_rect_Type2 x1 x2 x3 x4 h1 in hcut __ + +(** val add_stmt_inv_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + __ -> 'a1) -> 'a1 **) +let add_stmt_inv_inv_rect_Type1 x1 x2 x3 x4 h1 = + let hcut = add_stmt_inv_rect_Type1 x1 x2 x3 x4 h1 in hcut __ + +(** val add_stmt_inv_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + __ -> 'a1) -> 'a1 **) +let add_stmt_inv_inv_rect_Type0 x1 x2 x3 x4 h1 = + let hcut = add_stmt_inv_rect_Type0 x1 x2 x3 x4 h1 in hcut __ + +(** val add_stmt_inv_discr : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> __ **) +let add_stmt_inv_discr a1 a2 a3 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __)) __ + +(** val add_stmt_inv_jmdiscr : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> __ **) +let add_stmt_inv_jmdiscr a1 a2 a3 a4 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __)) __ + +type fn_con_because = +| Fn_con_eq of partial_fn +| Fn_con_sig of partial_fn * partial_fn * partial_fn Types.sig0 +| Fn_con_addinv of partial_fn * partial_fn * Cminor_syntax.stmt + * partial_fn Types.sig0 + +(** val fn_con_because_rect_Type4 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 **) +let rec fn_con_because_rect_Type4 fx h_fn_con_eq h_fn_con_sig h_fn_con_addinv x_15624 = function +| Fn_con_eq f -> h_fn_con_eq f +| Fn_con_sig (f1, f2, f3) -> h_fn_con_sig f1 f2 __ f3 +| Fn_con_addinv (f1, f2, s, f3) -> h_fn_con_addinv f1 f2 __ s f3 + +(** val fn_con_because_rect_Type5 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 **) +let rec fn_con_because_rect_Type5 fx h_fn_con_eq h_fn_con_sig h_fn_con_addinv x_15631 = function +| Fn_con_eq f -> h_fn_con_eq f +| Fn_con_sig (f1, f2, f3) -> h_fn_con_sig f1 f2 __ f3 +| Fn_con_addinv (f1, f2, s, f3) -> h_fn_con_addinv f1 f2 __ s f3 + +(** val fn_con_because_rect_Type3 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 **) +let rec fn_con_because_rect_Type3 fx h_fn_con_eq h_fn_con_sig h_fn_con_addinv x_15638 = function +| Fn_con_eq f -> h_fn_con_eq f +| Fn_con_sig (f1, f2, f3) -> h_fn_con_sig f1 f2 __ f3 +| Fn_con_addinv (f1, f2, s, f3) -> h_fn_con_addinv f1 f2 __ s f3 + +(** val fn_con_because_rect_Type2 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 **) +let rec fn_con_because_rect_Type2 fx h_fn_con_eq h_fn_con_sig h_fn_con_addinv x_15645 = function +| Fn_con_eq f -> h_fn_con_eq f +| Fn_con_sig (f1, f2, f3) -> h_fn_con_sig f1 f2 __ f3 +| Fn_con_addinv (f1, f2, s, f3) -> h_fn_con_addinv f1 f2 __ s f3 + +(** val fn_con_because_rect_Type1 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 **) +let rec fn_con_because_rect_Type1 fx h_fn_con_eq h_fn_con_sig h_fn_con_addinv x_15652 = function +| Fn_con_eq f -> h_fn_con_eq f +| Fn_con_sig (f1, f2, f3) -> h_fn_con_sig f1 f2 __ f3 +| Fn_con_addinv (f1, f2, s, f3) -> h_fn_con_addinv f1 f2 __ s f3 + +(** val fn_con_because_rect_Type0 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 **) +let rec fn_con_because_rect_Type0 fx h_fn_con_eq h_fn_con_sig h_fn_con_addinv x_15659 = function +| Fn_con_eq f -> h_fn_con_eq f +| Fn_con_sig (f1, f2, f3) -> h_fn_con_sig f1 f2 __ f3 +| Fn_con_addinv (f1, f2, s, f3) -> h_fn_con_addinv f1 f2 __ s f3 + +(** val fn_con_because_inv_rect_Type4 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) + -> (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ + -> 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> + partial_fn Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let fn_con_because_inv_rect_Type4 x1 x2 hterm h1 h2 h3 = + let hcut = fn_con_because_rect_Type4 x1 h1 h2 h3 x2 hterm in hcut __ __ + +(** val fn_con_because_inv_rect_Type3 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) + -> (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ + -> 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> + partial_fn Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let fn_con_because_inv_rect_Type3 x1 x2 hterm h1 h2 h3 = + let hcut = fn_con_because_rect_Type3 x1 h1 h2 h3 x2 hterm in hcut __ __ + +(** val fn_con_because_inv_rect_Type2 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) + -> (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ + -> 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> + partial_fn Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let fn_con_because_inv_rect_Type2 x1 x2 hterm h1 h2 h3 = + let hcut = fn_con_because_rect_Type2 x1 h1 h2 h3 x2 hterm in hcut __ __ + +(** val fn_con_because_inv_rect_Type1 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) + -> (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ + -> 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> + partial_fn Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let fn_con_because_inv_rect_Type1 x1 x2 hterm h1 h2 h3 = + let hcut = fn_con_because_rect_Type1 x1 h1 h2 h3 x2 hterm in hcut __ __ + +(** val fn_con_because_inv_rect_Type0 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) + -> (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ + -> 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> + partial_fn Types.sig0 -> __ -> __ -> 'a1) -> 'a1 **) +let fn_con_because_inv_rect_Type0 x1 x2 hterm h1 h2 h3 = + let hcut = fn_con_because_rect_Type0 x1 h1 h2 h3 x2 hterm in hcut __ __ + +(** val fn_con_because_discr : + fixed -> partial_fn -> fn_con_because -> fn_con_because -> __ **) +let fn_con_because_discr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Fn_con_eq a0 -> Obj.magic (fun _ dH -> dH __) + | Fn_con_sig (a0, a10, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Fn_con_addinv (a0, a10, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val fn_con_because_jmdiscr : + fixed -> partial_fn -> fn_con_because -> fn_con_because -> __ **) +let fn_con_because_jmdiscr a1 a2 x y = + Logic.eq_rect_Type2 x + (match x with + | Fn_con_eq a0 -> Obj.magic (fun _ dH -> dH __) + | Fn_con_sig (a0, a10, a3) -> Obj.magic (fun _ dH -> dH __ __ __ __) + | Fn_con_addinv (a0, a10, a3, a4) -> + Obj.magic (fun _ dH -> dH __ __ __ __ __)) y + +(** val fn_con_because_left : + fixed -> partial_fn -> fn_con_because -> partial_fn **) +let rec fn_con_because_left fx f0 = function +| Fn_con_eq f -> f +| Fn_con_sig (f, x, x1) -> f +| Fn_con_addinv (f, x, x1, x2) -> f + +(** val add_expr : + fixed -> AST.typ -> Cminor_syntax.expr -> partial_fn -> + Registers.register Types.sig0 -> partial_fn Types.sig0 **) +let rec add_expr fx ty e f dst = + (match e with + | Cminor_syntax.Id (t, i) -> + (fun _ dst0 -> + let r = lookup_reg fx.fx_env i t in + (match Registers.register_eq r (Types.pi1 dst0) with + | Types.Inl _ -> f + | Types.Inr _ -> + Types.pi1 + (add_fresh_to_graph fx (fun x -> RTLabs_syntax.St_op1 (t, t, + (FrontEndOps.Oid t), (Types.pi1 dst0), r, x)) f))) + | Cminor_syntax.Cst (x, c) -> + (fun _ dst0 -> + Types.pi1 + (add_fresh_to_graph fx (fun x0 -> RTLabs_syntax.St_const (x, + (Types.pi1 dst0), c, x0)) f)) + | Cminor_syntax.Op1 (t, t', op, e') -> + (fun _ dst0 -> + let { Types.dpi1 = f0; Types.dpi2 = r } = choose_reg fx t e' f in + let f1 = + add_fresh_to_graph fx (fun x -> RTLabs_syntax.St_op1 (t', t, op, + (Types.pi1 dst0), (Types.pi1 r), x)) (Types.pi1 f0) + in + let f2 = add_expr fx t e' (Types.pi1 f1) (Types.pi1 r) in Types.pi1 f2) + | Cminor_syntax.Op2 (x, x0, x1, op, e1, e2) -> + (fun _ dst0 -> + let { Types.dpi1 = f0; Types.dpi2 = r1 } = choose_reg fx x e1 f in + let { Types.dpi1 = f1; Types.dpi2 = r2 } = + choose_reg fx x0 e2 (Types.pi1 f0) + in + let f2 = + add_fresh_to_graph fx (fun x2 -> RTLabs_syntax.St_op2 (x1, x, x0, + op, (Types.pi1 dst0), (Types.pi1 r1), (Types.pi1 r2), x2)) + (Types.pi1 f1) + in + let f3 = add_expr fx x0 e2 (Types.pi1 f2) (Types.pi1 r2) in + let f4 = add_expr fx x e1 (Types.pi1 f3) (Types.pi1 r1) in + Types.pi1 f4) + | Cminor_syntax.Mem (t, e') -> + (fun _ dst0 -> + let { Types.dpi1 = f0; Types.dpi2 = r } = + choose_reg fx AST.ASTptr e' f + in + let f1 = + add_fresh_to_graph fx (fun x -> RTLabs_syntax.St_load (t, + (Types.pi1 r), (Types.pi1 dst0), x)) (Types.pi1 f0) + in + let f2 = add_expr fx AST.ASTptr e' (Types.pi1 f1) (Types.pi1 r) in + Types.pi1 f2) + | Cminor_syntax.Cond (x, x0, x1, e', e1, e2) -> + (fun _ dst0 -> + let resume_at = f.pf_entry in + let f0 = add_expr fx x1 e2 f dst0 in + let lfalse = (Types.pi1 f0).pf_entry in + let f1 = + add_fresh_to_graph fx (fun x2 -> RTLabs_syntax.St_skip + (Types.pi1 resume_at)) (Types.pi1 f0) + in + let f2 = add_expr fx x1 e1 (Types.pi1 f1) (Types.pi1 dst0) in + let { Types.dpi1 = f3; Types.dpi2 = r } = + choose_reg fx (AST.ASTint (x, x0)) e' (Types.pi1 f2) + in + let f4 = + add_fresh_to_graph fx (fun ltrue -> RTLabs_syntax.St_cond + ((Types.pi1 r), ltrue, (Types.pi1 lfalse))) (Types.pi1 f3) + in + let f5 = + add_expr fx (AST.ASTint (x, x0)) e' (Types.pi1 f4) (Types.pi1 r) + in + Types.pi1 f5) + | Cminor_syntax.Ecost (x, l, e') -> + (fun _ dst0 -> + let f0 = add_expr fx x e' f dst0 in + let f1 = + add_fresh_to_graph fx (fun x0 -> RTLabs_syntax.St_cost (l, x0)) + (Types.pi1 f0) + in + Types.pi1 f1)) __ dst + +(** val add_exprs : + fixed -> (AST.typ, Cminor_syntax.expr) Types.dPair List.list -> + Registers.register List.list -> partial_fn -> partial_fn Types.sig0 **) +let rec add_exprs fx es dsts f = + (match es with + | List.Nil -> + (fun _ _ -> + match dsts with + | List.Nil -> (fun _ -> f) + | List.Cons (x1, x2) -> (fun _ -> assert false (* absurd case *))) + | List.Cons (e, et) -> + (fun _ -> + match dsts with + | List.Nil -> (fun _ _ -> assert false (* absurd case *)) + | List.Cons (r, rt) -> + (fun _ _ -> + let f' = add_exprs fx et rt f in + (let { Types.dpi1 = ty; Types.dpi2 = e0 } = e in + (fun _ _ -> + let f'' = add_expr fx ty e0 (Types.pi1 f') r in Types.pi1 f'')) __ + __))) __ __ __ + +(** val stmt_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec stmt_inv_rect_Type4 fx s h_mk_stmt_inv = + h_mk_stmt_inv __ __ __ + +(** val stmt_inv_rect_Type5 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec stmt_inv_rect_Type5 fx s h_mk_stmt_inv = + h_mk_stmt_inv __ __ __ + +(** val stmt_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec stmt_inv_rect_Type3 fx s h_mk_stmt_inv = + h_mk_stmt_inv __ __ __ + +(** val stmt_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec stmt_inv_rect_Type2 fx s h_mk_stmt_inv = + h_mk_stmt_inv __ __ __ + +(** val stmt_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec stmt_inv_rect_Type1 fx s h_mk_stmt_inv = + h_mk_stmt_inv __ __ __ + +(** val stmt_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 **) +let rec stmt_inv_rect_Type0 fx s h_mk_stmt_inv = + h_mk_stmt_inv __ __ __ + +(** val stmt_inv_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let stmt_inv_inv_rect_Type4 x1 x2 h1 = + let hcut = stmt_inv_rect_Type4 x1 x2 h1 in hcut __ + +(** val stmt_inv_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let stmt_inv_inv_rect_Type3 x1 x2 h1 = + let hcut = stmt_inv_rect_Type3 x1 x2 h1 in hcut __ + +(** val stmt_inv_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let stmt_inv_inv_rect_Type2 x1 x2 h1 = + let hcut = stmt_inv_rect_Type2 x1 x2 h1 in hcut __ + +(** val stmt_inv_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let stmt_inv_inv_rect_Type1 x1 x2 h1 = + let hcut = stmt_inv_rect_Type1 x1 x2 h1 in hcut __ + +(** val stmt_inv_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let stmt_inv_inv_rect_Type0 x1 x2 h1 = + let hcut = stmt_inv_rect_Type0 x1 x2 h1 in hcut __ + +(** val stmt_inv_discr : fixed -> Cminor_syntax.stmt -> __ **) +let stmt_inv_discr a1 a2 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val stmt_inv_jmdiscr : fixed -> Cminor_syntax.stmt -> __ **) +let stmt_inv_jmdiscr a1 a2 = + Logic.eq_rect_Type2 __ (Obj.magic (fun _ dH -> dH __ __ __)) __ + +(** val expr_is_cst_ident : + AST.typ -> Cminor_syntax.expr -> AST.ident Types.option **) +let expr_is_cst_ident t = function +| Cminor_syntax.Id (x, x0) -> Types.None +| Cminor_syntax.Cst (x, c) -> + (match c with + | FrontEndOps.Ointconst (x0, x1, x2) -> Types.None + | FrontEndOps.Oaddrsymbol (id, n) -> + (match n with + | Nat.O -> Types.Some id + | Nat.S x0 -> Types.None) + | FrontEndOps.Oaddrstack x0 -> Types.None) +| Cminor_syntax.Op1 (x, x0, x1, x2) -> Types.None +| Cminor_syntax.Op2 (x, x0, x1, x2, x3, x4) -> Types.None +| Cminor_syntax.Mem (x, x0) -> Types.None +| Cminor_syntax.Cond (x, x0, x1, x2, x3, x4) -> Types.None +| Cminor_syntax.Ecost (x, x0, x1) -> Types.None + +(** val option_jmdiscr : 'a1 Types.option -> 'a1 Types.option -> __ **) +let option_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Types.None -> Obj.magic (fun _ dH -> dH) + | Types.Some a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val dPair_jmdiscr : + ('a1, 'a2) Types.dPair -> ('a1, 'a2) Types.dPair -> __ **) +let dPair_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { Types.dpi1 = a0; Types.dpi2 = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val add_return : + fixed -> (AST.typ, Cminor_syntax.expr) Types.dPair Types.option -> + partial_fn -> partial_fn Types.sig0 **) +let add_return fx opt_e f = + let f0 = f in + let f1 = change_entry fx f (Types.pi1 f.pf_exit) in + (match opt_e with + | Types.None -> (fun _ -> Types.pi1 f1) + | Types.Some et -> + let { Types.dpi1 = ty; Types.dpi2 = e } = et in + (fun _ -> + (match fx.fx_rettyp with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some t -> + (fun _ r -> + let r0 = Obj.magic r in + let f2 = add_expr fx ty e (Types.pi1 f1) r0 in Types.pi1 f2)) __ + (Types.pi1 f1).pf_result)) __ + +(** val record_goto_label : + fixed -> partial_fn -> PreIdentifiers.identifier -> partial_fn **) +let record_goto_label fx f l = + { pf_labgen = f.pf_labgen; pf_reggen = f.pf_reggen; pf_params = + f.pf_params; pf_locals = f.pf_locals; pf_result = f.pf_result; + pf_stacksize = f.pf_stacksize; pf_graph = f.pf_graph; pf_gotos = + f.pf_gotos; pf_labels = + (Identifiers.add PreIdentifiers.Label (Types.pi1 f.pf_labels) l + (Types.pi1 f.pf_entry)); pf_entry = f.pf_entry; pf_exit = f.pf_exit } + +(** val add_goto_dummy : + fixed -> partial_fn -> PreIdentifiers.identifier -> partial_fn Types.sig0 **) +let add_goto_dummy fx f dest = + (let { Types.fst = l; Types.snd = g } = + Identifiers.fresh PreIdentifiers.LabelTag f.pf_labgen + in + (fun _ -> { pf_labgen = g; pf_reggen = f.pf_reggen; pf_params = + f.pf_params; pf_locals = f.pf_locals; pf_result = f.pf_result; + pf_stacksize = f.pf_stacksize; pf_graph = + (Identifiers.add PreIdentifiers.LabelTag f.pf_graph l + (RTLabs_syntax.St_skip l)); pf_gotos = + (Identifiers.add PreIdentifiers.LabelTag (gm_map fx f.pf_graph f.pf_gotos) + l dest); pf_labels = (Types.pi1 f.pf_labels); pf_entry = l; pf_exit = + (Types.pi1 f.pf_exit) })) __ + +(** val add_stmt : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn Types.sig0 **) +let rec add_stmt fx s f = + (match s with + | Cminor_syntax.St_skip -> (fun _ -> f) + | Cminor_syntax.St_assign (t, x, e) -> + (fun _ -> + let dst = lookup_reg fx.fx_env x t in + Types.pi1 (add_expr fx t e f dst)) + | Cminor_syntax.St_store (t, e1, e2) -> + (fun _ -> + let { Types.dpi1 = f0; Types.dpi2 = val_reg } = choose_reg fx t e2 f + in + let { Types.dpi1 = f1; Types.dpi2 = addr_reg } = + choose_reg fx AST.ASTptr e1 (Types.pi1 f0) + in + let f2 = + add_fresh_to_graph fx (fun x -> RTLabs_syntax.St_store (t, + (Types.pi1 addr_reg), (Types.pi1 val_reg), x)) (Types.pi1 f1) + in + let f3 = add_expr fx AST.ASTptr e1 (Types.pi1 f2) (Types.pi1 addr_reg) + in + Types.pi1 (add_expr fx t e2 (Types.pi1 f3) (Types.pi1 val_reg))) + | Cminor_syntax.St_call (return_opt_id, e, args) -> + (fun _ -> + let return_opt_reg = + (match return_opt_id with + | Types.None -> (fun _ -> Types.None) + | Types.Some idty -> + (fun _ -> Types.Some + (lookup_reg fx.fx_env idty.Types.fst idty.Types.snd))) __ + in + let { Types.dpi1 = f0; Types.dpi2 = args_regs } = + choose_regs fx args f + in + let f1 = + match expr_is_cst_ident AST.ASTptr e with + | Types.None -> + let { Types.dpi1 = f1; Types.dpi2 = fnr } = + choose_reg fx AST.ASTptr e (Types.pi1 f0) + in + let f2 = + add_fresh_to_graph fx (fun x -> RTLabs_syntax.St_call_ptr + ((Types.pi1 fnr), (Types.pi1 args_regs), return_opt_reg, x)) + (Types.pi1 f1) + in + Types.pi1 + (add_expr fx AST.ASTptr e (Types.pi1 f2) (Types.pi1 fnr)) + | Types.Some id -> + add_fresh_to_graph fx (fun x -> RTLabs_syntax.St_call_id (id, + (Types.pi1 args_regs), return_opt_reg, x)) (Types.pi1 f0) + in + Types.pi1 (add_exprs fx args (Types.pi1 args_regs) (Types.pi1 f1))) + | Cminor_syntax.St_seq (s1, s2) -> + (fun _ -> + let f2 = add_stmt fx s2 f in + let f1 = add_stmt fx s1 (Types.pi1 f2) in Types.pi1 f1) + | Cminor_syntax.St_ifthenelse (x, x0, e, s1, s2) -> + (fun _ -> + let l_next = f.pf_entry in + let f2 = add_stmt fx s2 f in + let l2 = (Types.pi1 f2).pf_entry in + let f0 = change_entry fx (Types.pi1 f2) (Types.pi1 l_next) in + let f1 = add_stmt fx s1 (Types.pi1 f0) in + let { Types.dpi1 = f3; Types.dpi2 = r } = + choose_reg fx (AST.ASTint (x, x0)) e (Types.pi1 f1) + in + let f4 = + add_fresh_to_graph fx (fun l1 -> RTLabs_syntax.St_cond + ((Types.pi1 r), l1, (Types.pi1 l2))) (Types.pi1 f3) + in + Types.pi1 + (add_expr fx (AST.ASTint (x, x0)) e (Types.pi1 f4) (Types.pi1 r))) + | Cminor_syntax.St_return opt_e -> (fun _ -> add_return fx opt_e f) + | Cminor_syntax.St_label (l, s') -> + (fun _ -> + let f0 = add_stmt fx s' f in record_goto_label fx (Types.pi1 f0) l) + | Cminor_syntax.St_goto l -> (fun _ -> Types.pi1 (add_goto_dummy fx f l)) + | Cminor_syntax.St_cost (l, s') -> + (fun _ -> + let f0 = add_stmt fx s' f in + Types.pi1 + (add_fresh_to_graph fx (fun x -> RTLabs_syntax.St_cost (l, x)) + (Types.pi1 f0)))) __ + +(** val patch_gotos : fixed -> partial_fn -> partial_fn Types.sig0 **) +let patch_gotos fx f = + Identifiers.fold_inf PreIdentifiers.LabelTag + (gm_map fx f.pf_graph f.pf_gotos) (fun l l' _ f' -> + Types.pi1 + (fill_in_statement fx l (RTLabs_syntax.St_skip + (Identifiers.lookup_present PreIdentifiers.Label + (Types.pi1 (Types.pi1 f').pf_labels) l')) (Types.pi1 f'))) f + +(** val c2ra_function : + Cminor_syntax.internal_function -> RTLabs_syntax.internal_function **) +let c2ra_function f = + let labgen0 = Identifiers.new_universe PreIdentifiers.LabelTag in + let reggen0 = Identifiers.new_universe PreIdentifiers.RegisterTag in + let cminor_labels = Cminor_syntax.labels_of f.Cminor_syntax.f_body in + (let { Types.fst = eta3086; Types.snd = reggen1 } = + populate_env (Identifiers.empty_map PreIdentifiers.SymbolTag) reggen0 + f.Cminor_syntax.f_params + in + let { Types.fst = params; Types.snd = env1 } = eta3086 in + (fun _ -> + (let { Types.fst = eta3085; Types.snd = reggen2 } = + populate_env env1 reggen1 f.Cminor_syntax.f_vars + in + let { Types.fst = locals0; Types.snd = env0 } = eta3085 in + (fun _ -> + (let { Types.dpi1 = locals_reggen; Types.dpi2 = result } = + match f.Cminor_syntax.f_return with + | Types.None -> + { Types.dpi1 = { Types.fst = locals0; Types.snd = reggen2 }; + Types.dpi2 = (Obj.magic __) } + | Types.Some ty -> + let { Types.fst = r; Types.snd = gen } = + Identifiers.fresh PreIdentifiers.RegisterTag reggen2 + in + { Types.dpi1 = { Types.fst = (List.Cons ({ Types.fst = r; Types.snd = + ty }, locals0)); Types.snd = gen }; Types.dpi2 = r } + in + (fun _ -> + let locals = locals_reggen.Types.fst in + let reggen = locals_reggen.Types.snd in + let { Types.fst = l; Types.snd = labgen } = + Identifiers.fresh PreIdentifiers.LabelTag labgen0 + in + let fixed0 = { fx_gotos = + (Identifiers.set_of_list PreIdentifiers.Label + (Cminor_syntax.labels_of f.Cminor_syntax.f_body)); fx_env = env0; + fx_rettyp = f.Cminor_syntax.f_return } + in + let emptyfn = { pf_labgen = labgen; pf_reggen = reggen; pf_params = params; + pf_locals = locals; pf_result = (Obj.magic result); pf_stacksize = + f.Cminor_syntax.f_stacksize; pf_graph = + (Identifiers.add PreIdentifiers.LabelTag + (Identifiers.empty_map PreIdentifiers.LabelTag) l + RTLabs_syntax.St_return); pf_gotos = + (Identifiers.empty_map PreIdentifiers.LabelTag); pf_labels = + (Identifiers.empty_map PreIdentifiers.Label); pf_entry = l; pf_exit = l } + in + let f0 = add_stmt fixed0 f.Cminor_syntax.f_body emptyfn in + let f1 = patch_gotos fixed0 (Types.pi1 f0) in + { RTLabs_syntax.f_labgen = (Types.pi1 f1).pf_labgen; + RTLabs_syntax.f_reggen = (Types.pi1 f1).pf_reggen; RTLabs_syntax.f_result = + ((match fixed0.fx_rettyp with + | Types.None -> Obj.magic (fun _ -> Types.None) + | Types.Some t -> + (fun r -> Types.Some { Types.fst = (Types.pi1 (Obj.magic r)); + Types.snd = t })) (Types.pi1 f1).pf_result); RTLabs_syntax.f_params = + (Types.pi1 f1).pf_params; RTLabs_syntax.f_locals = + (Types.pi1 f1).pf_locals; RTLabs_syntax.f_stacksize = + (Types.pi1 f1).pf_stacksize; RTLabs_syntax.f_graph = + (Types.pi1 f1).pf_graph; RTLabs_syntax.f_entry = (Types.pi1 f1).pf_entry; + RTLabs_syntax.f_exit = (Types.pi1 f1).pf_exit })) __)) __)) __ + +(** val cminor_to_rtlabs : + Cminor_syntax.cminor_program -> RTLabs_syntax.rTLabs_program **) +let cminor_to_rtlabs p = + AST.transform_program p (fun x -> AST.transf_fundef c2ra_function) + diff --git a/extracted/toRTLabs.mli b/extracted/toRTLabs.mli new file mode 100644 index 0000000..8ae519a --- /dev/null +++ b/extracted/toRTLabs.mli @@ -0,0 +1,681 @@ +open Preamble + +open Setoids + +open Monad + +open Option + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Lists + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Positive + +open PreIdentifiers + +open Errors + +open Globalenvs + +open CostLabel + +open FrontEndOps + +open Cminor_syntax + +open BitVectorTrie + +open Graphs + +open Order + +open Registers + +open RTLabs_syntax + +type env = + (Registers.register, AST.typ) Types.prod Identifiers.identifier_map + +val populate_env : + env -> Identifiers.universe -> (AST.ident, AST.typ) Types.prod List.list -> + (((Registers.register, AST.typ) Types.prod List.list, env) Types.prod, + Identifiers.universe) Types.prod + +val lookup_reg : env -> AST.ident -> AST.typ -> Registers.register + +type fixed = { fx_gotos : Identifiers.identifier_set; fx_env : env; + fx_rettyp : AST.typ Types.option } + +val fixed_rect_Type4 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> fixed + -> 'a1 + +val fixed_rect_Type5 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> fixed + -> 'a1 + +val fixed_rect_Type3 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> fixed + -> 'a1 + +val fixed_rect_Type2 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> fixed + -> 'a1 + +val fixed_rect_Type1 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> fixed + -> 'a1 + +val fixed_rect_Type0 : + (Identifiers.identifier_set -> env -> AST.typ Types.option -> 'a1) -> fixed + -> 'a1 + +val fx_gotos : fixed -> Identifiers.identifier_set + +val fx_env : fixed -> env + +val fx_rettyp : fixed -> AST.typ Types.option + +val fixed_inv_rect_Type4 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 + +val fixed_inv_rect_Type3 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 + +val fixed_inv_rect_Type2 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 + +val fixed_inv_rect_Type1 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 + +val fixed_inv_rect_Type0 : + fixed -> (Identifiers.identifier_set -> env -> AST.typ Types.option -> __ + -> 'a1) -> 'a1 + +val fixed_discr : fixed -> fixed -> __ + +val fixed_jmdiscr : fixed -> fixed -> __ + +type resultok = __ + +type goto_map = + PreIdentifiers.identifier Identifiers.identifier_map + (* singleton inductive, whose constructor was mk_goto_map *) + +val goto_map_rect_Type4 : + fixed -> RTLabs_syntax.statement Graphs.graph -> (PreIdentifiers.identifier + Identifiers.identifier_map -> __ -> __ -> 'a1) -> goto_map -> 'a1 + +val goto_map_rect_Type5 : + fixed -> RTLabs_syntax.statement Graphs.graph -> (PreIdentifiers.identifier + Identifiers.identifier_map -> __ -> __ -> 'a1) -> goto_map -> 'a1 + +val goto_map_rect_Type3 : + fixed -> RTLabs_syntax.statement Graphs.graph -> (PreIdentifiers.identifier + Identifiers.identifier_map -> __ -> __ -> 'a1) -> goto_map -> 'a1 + +val goto_map_rect_Type2 : + fixed -> RTLabs_syntax.statement Graphs.graph -> (PreIdentifiers.identifier + Identifiers.identifier_map -> __ -> __ -> 'a1) -> goto_map -> 'a1 + +val goto_map_rect_Type1 : + fixed -> RTLabs_syntax.statement Graphs.graph -> (PreIdentifiers.identifier + Identifiers.identifier_map -> __ -> __ -> 'a1) -> goto_map -> 'a1 + +val goto_map_rect_Type0 : + fixed -> RTLabs_syntax.statement Graphs.graph -> (PreIdentifiers.identifier + Identifiers.identifier_map -> __ -> __ -> 'a1) -> goto_map -> 'a1 + +val gm_map : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map + +val goto_map_inv_rect_Type4 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val goto_map_inv_rect_Type3 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val goto_map_inv_rect_Type2 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val goto_map_inv_rect_Type1 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val goto_map_inv_rect_Type0 : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + (PreIdentifiers.identifier Identifiers.identifier_map -> __ -> __ -> __ -> + 'a1) -> 'a1 + +val goto_map_discr : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> goto_map -> __ + +val goto_map_jmdiscr : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> goto_map -> __ + +val dpi1__o__gm_map__o__inject : + fixed -> RTLabs_syntax.statement Graphs.graph -> (goto_map, 'a1) + Types.dPair -> PreIdentifiers.identifier Identifiers.identifier_map + Types.sig0 + +val eject__o__gm_map__o__inject : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map Types.sig0 -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 + +val gm_map__o__inject : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 + +val dpi1__o__gm_map : + fixed -> RTLabs_syntax.statement Graphs.graph -> (goto_map, 'a1) + Types.dPair -> PreIdentifiers.identifier Identifiers.identifier_map + +val eject__o__gm_map : + fixed -> RTLabs_syntax.statement Graphs.graph -> goto_map Types.sig0 -> + PreIdentifiers.identifier Identifiers.identifier_map + +type partial_fn = { pf_labgen : Identifiers.universe; + pf_reggen : Identifiers.universe; + pf_params : (Registers.register, AST.typ) Types.prod + List.list; + pf_locals : (Registers.register, AST.typ) Types.prod + List.list; pf_result : resultok; + pf_stacksize : Nat.nat; + pf_graph : RTLabs_syntax.statement Graphs.graph; + pf_gotos : goto_map; + pf_labels : PreIdentifiers.identifier + Identifiers.identifier_map Types.sig0; + pf_entry : Graphs.label Types.sig0; + pf_exit : Graphs.label Types.sig0 } + +val partial_fn_rect_Type4 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 + +val partial_fn_rect_Type5 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 + +val partial_fn_rect_Type3 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 + +val partial_fn_rect_Type2 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 + +val partial_fn_rect_Type1 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 + +val partial_fn_rect_Type0 : + fixed -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> 'a1) -> + partial_fn -> 'a1 + +val pf_labgen : fixed -> partial_fn -> Identifiers.universe + +val pf_reggen : fixed -> partial_fn -> Identifiers.universe + +val pf_params : + fixed -> partial_fn -> (Registers.register, AST.typ) Types.prod List.list + +val pf_locals : + fixed -> partial_fn -> (Registers.register, AST.typ) Types.prod List.list + +val pf_result : fixed -> partial_fn -> resultok + +val pf_stacksize : fixed -> partial_fn -> Nat.nat + +val pf_graph : fixed -> partial_fn -> RTLabs_syntax.statement Graphs.graph + +val pf_gotos : fixed -> partial_fn -> goto_map + +val pf_labels : + fixed -> partial_fn -> PreIdentifiers.identifier Identifiers.identifier_map + Types.sig0 + +val pf_entry : fixed -> partial_fn -> Graphs.label Types.sig0 + +val pf_exit : fixed -> partial_fn -> Graphs.label Types.sig0 + +val partial_fn_inv_rect_Type4 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 + +val partial_fn_inv_rect_Type3 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 + +val partial_fn_inv_rect_Type2 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 + +val partial_fn_inv_rect_Type1 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 + +val partial_fn_inv_rect_Type0 : + fixed -> partial_fn -> (Identifiers.universe -> Identifiers.universe -> + (Registers.register, AST.typ) Types.prod List.list -> (Registers.register, + AST.typ) Types.prod List.list -> resultok -> __ -> Nat.nat -> + RTLabs_syntax.statement Graphs.graph -> __ -> goto_map -> + PreIdentifiers.identifier Identifiers.identifier_map Types.sig0 -> __ -> + Graphs.label Types.sig0 -> Graphs.label Types.sig0 -> __ -> __ -> 'a1) -> + 'a1 + +val partial_fn_jmdiscr : fixed -> partial_fn -> partial_fn -> __ + +val fn_contains_rect_Type4 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_rect_Type5 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_rect_Type3 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_rect_Type2 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_rect_Type1 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_rect_Type0 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_inv_rect_Type4 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_inv_rect_Type3 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_inv_rect_Type2 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_inv_rect_Type1 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_inv_rect_Type0 : + fixed -> partial_fn -> partial_fn -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val fn_contains_discr : fixed -> partial_fn -> partial_fn -> __ + +val fn_contains_jmdiscr : fixed -> partial_fn -> partial_fn -> __ + +val fill_in_statement : + fixed -> Graphs.label -> RTLabs_syntax.statement -> partial_fn -> + partial_fn Types.sig0 + +val add_to_graph : + fixed -> Graphs.label -> RTLabs_syntax.statement -> partial_fn -> + partial_fn Types.sig0 + +val change_entry : + fixed -> partial_fn -> PreIdentifiers.identifier -> partial_fn Types.sig0 + +val add_fresh_to_graph : + fixed -> (Graphs.label -> RTLabs_syntax.statement) -> partial_fn -> + partial_fn Types.sig0 + +val fresh_reg : + fixed -> partial_fn -> AST.typ -> (partial_fn Types.sig0, + Registers.register Types.sig0) Types.dPair + +val choose_reg : + fixed -> AST.typ -> Cminor_syntax.expr -> partial_fn -> (partial_fn + Types.sig0, Registers.register Types.sig0) Types.dPair + +val foldr_all : ('a1 -> __ -> 'a2 -> 'a2) -> 'a2 -> 'a1 List.list -> 'a2 + +val foldr_all' : + ('a1 -> __ -> 'a1 List.list -> 'a2 -> 'a2) -> 'a2 -> 'a1 List.list -> 'a2 + +val eject' : ('a1, 'a2) Types.dPair -> 'a1 + +val choose_regs : + fixed -> (AST.typ, Cminor_syntax.expr) Types.dPair List.list -> partial_fn + -> (partial_fn Types.sig0, Registers.register List.list Types.sig0) + Types.dPair + +val add_stmt_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 + +val add_stmt_inv_rect_Type5 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 + +val add_stmt_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 + +val add_stmt_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 + +val add_stmt_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 + +val add_stmt_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> + 'a1) -> 'a1 + +val add_stmt_inv_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> __ + -> 'a1) -> 'a1 + +val add_stmt_inv_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> __ + -> 'a1) -> 'a1 + +val add_stmt_inv_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> __ + -> 'a1) -> 'a1 + +val add_stmt_inv_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> __ + -> 'a1) -> 'a1 + +val add_stmt_inv_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> (__ -> __ -> __ + -> 'a1) -> 'a1 + +val add_stmt_inv_discr : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> __ + +val add_stmt_inv_jmdiscr : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn -> __ + +type fn_con_because = +| Fn_con_eq of partial_fn +| Fn_con_sig of partial_fn * partial_fn * partial_fn Types.sig0 +| Fn_con_addinv of partial_fn * partial_fn * Cminor_syntax.stmt + * partial_fn Types.sig0 + +val fn_con_because_rect_Type4 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 + +val fn_con_because_rect_Type5 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 + +val fn_con_because_rect_Type3 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 + +val fn_con_because_rect_Type2 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 + +val fn_con_because_rect_Type1 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 + +val fn_con_because_rect_Type0 : + fixed -> (partial_fn -> 'a1) -> (partial_fn -> partial_fn -> __ -> + partial_fn Types.sig0 -> 'a1) -> (partial_fn -> partial_fn -> __ -> + Cminor_syntax.stmt -> partial_fn Types.sig0 -> 'a1) -> partial_fn -> + fn_con_because -> 'a1 + +val fn_con_because_inv_rect_Type4 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) -> + (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ -> + 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> partial_fn + Types.sig0 -> __ -> __ -> 'a1) -> 'a1 + +val fn_con_because_inv_rect_Type3 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) -> + (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ -> + 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> partial_fn + Types.sig0 -> __ -> __ -> 'a1) -> 'a1 + +val fn_con_because_inv_rect_Type2 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) -> + (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ -> + 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> partial_fn + Types.sig0 -> __ -> __ -> 'a1) -> 'a1 + +val fn_con_because_inv_rect_Type1 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) -> + (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ -> + 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> partial_fn + Types.sig0 -> __ -> __ -> 'a1) -> 'a1 + +val fn_con_because_inv_rect_Type0 : + fixed -> partial_fn -> fn_con_because -> (partial_fn -> __ -> __ -> 'a1) -> + (partial_fn -> partial_fn -> __ -> partial_fn Types.sig0 -> __ -> __ -> + 'a1) -> (partial_fn -> partial_fn -> __ -> Cminor_syntax.stmt -> partial_fn + Types.sig0 -> __ -> __ -> 'a1) -> 'a1 + +val fn_con_because_discr : + fixed -> partial_fn -> fn_con_because -> fn_con_because -> __ + +val fn_con_because_jmdiscr : + fixed -> partial_fn -> fn_con_because -> fn_con_because -> __ + +val fn_con_because_left : fixed -> partial_fn -> fn_con_because -> partial_fn + +val add_expr : + fixed -> AST.typ -> Cminor_syntax.expr -> partial_fn -> Registers.register + Types.sig0 -> partial_fn Types.sig0 + +val add_exprs : + fixed -> (AST.typ, Cminor_syntax.expr) Types.dPair List.list -> + Registers.register List.list -> partial_fn -> partial_fn Types.sig0 + +val stmt_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type5 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_inv_rect_Type4 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_inv_rect_Type3 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_inv_rect_Type2 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_inv_rect_Type1 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_inv_rect_Type0 : + fixed -> Cminor_syntax.stmt -> (__ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val stmt_inv_discr : fixed -> Cminor_syntax.stmt -> __ + +val stmt_inv_jmdiscr : fixed -> Cminor_syntax.stmt -> __ + +val expr_is_cst_ident : + AST.typ -> Cminor_syntax.expr -> AST.ident Types.option + +val option_jmdiscr : 'a1 Types.option -> 'a1 Types.option -> __ + +val dPair_jmdiscr : ('a1, 'a2) Types.dPair -> ('a1, 'a2) Types.dPair -> __ + +val add_return : + fixed -> (AST.typ, Cminor_syntax.expr) Types.dPair Types.option -> + partial_fn -> partial_fn Types.sig0 + +val record_goto_label : + fixed -> partial_fn -> PreIdentifiers.identifier -> partial_fn + +val add_goto_dummy : + fixed -> partial_fn -> PreIdentifiers.identifier -> partial_fn Types.sig0 + +val add_stmt : + fixed -> Cminor_syntax.stmt -> partial_fn -> partial_fn Types.sig0 + +val patch_gotos : fixed -> partial_fn -> partial_fn Types.sig0 + +val c2ra_function : + Cminor_syntax.internal_function -> RTLabs_syntax.internal_function + +val cminor_to_rtlabs : + Cminor_syntax.cminor_program -> RTLabs_syntax.rTLabs_program + diff --git a/extracted/traces.ml b/extracted/traces.ml new file mode 100644 index 0000000..e02a1fe --- /dev/null +++ b/extracted/traces.ml @@ -0,0 +1,711 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open StructuredTraces + +type evaluation_params = { globals : AST.ident List.list; + ev_genv : Joint_semantics.genv } + +(** val evaluation_params_rect_Type4 : + Joint_semantics.sem_params -> (AST.ident List.list -> + Joint_semantics.genv -> 'a1) -> evaluation_params -> 'a1 **) +let rec evaluation_params_rect_Type4 p h_mk_evaluation_params x_25115 = + let { globals = globals0; ev_genv = ev_genv0 } = x_25115 in + h_mk_evaluation_params globals0 ev_genv0 + +(** val evaluation_params_rect_Type5 : + Joint_semantics.sem_params -> (AST.ident List.list -> + Joint_semantics.genv -> 'a1) -> evaluation_params -> 'a1 **) +let rec evaluation_params_rect_Type5 p h_mk_evaluation_params x_25117 = + let { globals = globals0; ev_genv = ev_genv0 } = x_25117 in + h_mk_evaluation_params globals0 ev_genv0 + +(** val evaluation_params_rect_Type3 : + Joint_semantics.sem_params -> (AST.ident List.list -> + Joint_semantics.genv -> 'a1) -> evaluation_params -> 'a1 **) +let rec evaluation_params_rect_Type3 p h_mk_evaluation_params x_25119 = + let { globals = globals0; ev_genv = ev_genv0 } = x_25119 in + h_mk_evaluation_params globals0 ev_genv0 + +(** val evaluation_params_rect_Type2 : + Joint_semantics.sem_params -> (AST.ident List.list -> + Joint_semantics.genv -> 'a1) -> evaluation_params -> 'a1 **) +let rec evaluation_params_rect_Type2 p h_mk_evaluation_params x_25121 = + let { globals = globals0; ev_genv = ev_genv0 } = x_25121 in + h_mk_evaluation_params globals0 ev_genv0 + +(** val evaluation_params_rect_Type1 : + Joint_semantics.sem_params -> (AST.ident List.list -> + Joint_semantics.genv -> 'a1) -> evaluation_params -> 'a1 **) +let rec evaluation_params_rect_Type1 p h_mk_evaluation_params x_25123 = + let { globals = globals0; ev_genv = ev_genv0 } = x_25123 in + h_mk_evaluation_params globals0 ev_genv0 + +(** val evaluation_params_rect_Type0 : + Joint_semantics.sem_params -> (AST.ident List.list -> + Joint_semantics.genv -> 'a1) -> evaluation_params -> 'a1 **) +let rec evaluation_params_rect_Type0 p h_mk_evaluation_params x_25125 = + let { globals = globals0; ev_genv = ev_genv0 } = x_25125 in + h_mk_evaluation_params globals0 ev_genv0 + +(** val globals : + Joint_semantics.sem_params -> evaluation_params -> AST.ident List.list **) +let rec globals p xxx = + xxx.globals + +(** val ev_genv : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.genv **) +let rec ev_genv p xxx = + xxx.ev_genv + +(** val evaluation_params_inv_rect_Type4 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list + -> Joint_semantics.genv -> __ -> 'a1) -> 'a1 **) +let evaluation_params_inv_rect_Type4 x1 hterm h1 = + let hcut = evaluation_params_rect_Type4 x1 h1 hterm in hcut __ + +(** val evaluation_params_inv_rect_Type3 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list + -> Joint_semantics.genv -> __ -> 'a1) -> 'a1 **) +let evaluation_params_inv_rect_Type3 x1 hterm h1 = + let hcut = evaluation_params_rect_Type3 x1 h1 hterm in hcut __ + +(** val evaluation_params_inv_rect_Type2 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list + -> Joint_semantics.genv -> __ -> 'a1) -> 'a1 **) +let evaluation_params_inv_rect_Type2 x1 hterm h1 = + let hcut = evaluation_params_rect_Type2 x1 h1 hterm in hcut __ + +(** val evaluation_params_inv_rect_Type1 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list + -> Joint_semantics.genv -> __ -> 'a1) -> 'a1 **) +let evaluation_params_inv_rect_Type1 x1 hterm h1 = + let hcut = evaluation_params_rect_Type1 x1 h1 hterm in hcut __ + +(** val evaluation_params_inv_rect_Type0 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list + -> Joint_semantics.genv -> __ -> 'a1) -> 'a1 **) +let evaluation_params_inv_rect_Type0 x1 hterm h1 = + let hcut = evaluation_params_rect_Type0 x1 h1 hterm in hcut __ + +(** val evaluation_params_discr : + Joint_semantics.sem_params -> evaluation_params -> evaluation_params -> + __ **) +let evaluation_params_discr a1 x y = + Logic.eq_rect_Type2 x + (let { globals = a0; ev_genv = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val evaluation_params_jmdiscr : + Joint_semantics.sem_params -> evaluation_params -> evaluation_params -> + __ **) +let evaluation_params_jmdiscr a1 x y = + Logic.eq_rect_Type2 x + (let { globals = a0; ev_genv = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val dpi1__o__ev_genv__o__inject : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint_semantics.genv Types.sig0 **) +let dpi1__o__ev_genv__o__inject x0 x2 = + x2.Types.dpi1.ev_genv + +(** val dpi1__o__ev_genv__o__ge__o__inject : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + Types.sig0 **) +let dpi1__o__ev_genv__o__ge__o__inject x0 x2 = + Joint_semantics.ge__o__inject x2.Types.dpi1.globals x2.Types.dpi1.ev_genv + +(** val dpi1__o__ev_genv__o__ge : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t **) +let dpi1__o__ev_genv__o__ge x0 x2 = + x2.Types.dpi1.ev_genv.Joint_semantics.ge + +(** val eject__o__ev_genv__o__inject : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint_semantics.genv Types.sig0 **) +let eject__o__ev_genv__o__inject x0 x2 = + (Types.pi1 x2).ev_genv + +(** val eject__o__ev_genv__o__ge__o__inject : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + Types.sig0 **) +let eject__o__ev_genv__o__ge__o__inject x0 x2 = + Joint_semantics.ge__o__inject (Types.pi1 x2).globals (Types.pi1 x2).ev_genv + +(** val eject__o__ev_genv__o__ge : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t **) +let eject__o__ev_genv__o__ge x0 x2 = + (Types.pi1 x2).ev_genv.Joint_semantics.ge + +(** val ev_genv__o__ge : + Joint_semantics.sem_params -> evaluation_params -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t **) +let ev_genv__o__ge x0 x1 = + x1.ev_genv.Joint_semantics.ge + +(** val ev_genv__o__ge__o__inject : + Joint_semantics.sem_params -> evaluation_params -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + Types.sig0 **) +let ev_genv__o__ge__o__inject x0 x1 = + Joint_semantics.ge__o__inject x1.globals x1.ev_genv + +(** val ev_genv__o__inject : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.genv + Types.sig0 **) +let ev_genv__o__inject x0 x1 = + x1.ev_genv + +(** val dpi1__o__ev_genv : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint_semantics.genv **) +let dpi1__o__ev_genv x0 x2 = + x2.Types.dpi1.ev_genv + +(** val eject__o__ev_genv : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint_semantics.genv **) +let eject__o__ev_genv x0 x2 = + (Types.pi1 x2).ev_genv + +type prog_params = { prog_spars : Joint_semantics.sem_params; + prog : Joint.joint_program; + stack_sizes : (AST.ident -> Nat.nat Types.option) } + +(** val prog_params_rect_Type4 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> 'a1) -> prog_params -> 'a1 **) +let rec prog_params_rect_Type4 h_mk_prog_params x_25141 = + let { prog_spars = prog_spars0; prog = prog0; stack_sizes = + stack_sizes0 } = x_25141 + in + h_mk_prog_params prog_spars0 prog0 stack_sizes0 + +(** val prog_params_rect_Type5 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> 'a1) -> prog_params -> 'a1 **) +let rec prog_params_rect_Type5 h_mk_prog_params x_25143 = + let { prog_spars = prog_spars0; prog = prog0; stack_sizes = + stack_sizes0 } = x_25143 + in + h_mk_prog_params prog_spars0 prog0 stack_sizes0 + +(** val prog_params_rect_Type3 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> 'a1) -> prog_params -> 'a1 **) +let rec prog_params_rect_Type3 h_mk_prog_params x_25145 = + let { prog_spars = prog_spars0; prog = prog0; stack_sizes = + stack_sizes0 } = x_25145 + in + h_mk_prog_params prog_spars0 prog0 stack_sizes0 + +(** val prog_params_rect_Type2 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> 'a1) -> prog_params -> 'a1 **) +let rec prog_params_rect_Type2 h_mk_prog_params x_25147 = + let { prog_spars = prog_spars0; prog = prog0; stack_sizes = + stack_sizes0 } = x_25147 + in + h_mk_prog_params prog_spars0 prog0 stack_sizes0 + +(** val prog_params_rect_Type1 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> 'a1) -> prog_params -> 'a1 **) +let rec prog_params_rect_Type1 h_mk_prog_params x_25149 = + let { prog_spars = prog_spars0; prog = prog0; stack_sizes = + stack_sizes0 } = x_25149 + in + h_mk_prog_params prog_spars0 prog0 stack_sizes0 + +(** val prog_params_rect_Type0 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> 'a1) -> prog_params -> 'a1 **) +let rec prog_params_rect_Type0 h_mk_prog_params x_25151 = + let { prog_spars = prog_spars0; prog = prog0; stack_sizes = + stack_sizes0 } = x_25151 + in + h_mk_prog_params prog_spars0 prog0 stack_sizes0 + +(** val prog_spars : prog_params -> Joint_semantics.sem_params **) +let rec prog_spars xxx = + xxx.prog_spars + +(** val prog : prog_params -> Joint.joint_program **) +let rec prog xxx = + xxx.prog + +(** val stack_sizes : prog_params -> AST.ident -> Nat.nat Types.option **) +let rec stack_sizes xxx = + xxx.stack_sizes + +(** val prog_params_inv_rect_Type4 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 **) +let prog_params_inv_rect_Type4 hterm h1 = + let hcut = prog_params_rect_Type4 h1 hterm in hcut __ + +(** val prog_params_inv_rect_Type3 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 **) +let prog_params_inv_rect_Type3 hterm h1 = + let hcut = prog_params_rect_Type3 h1 hterm in hcut __ + +(** val prog_params_inv_rect_Type2 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 **) +let prog_params_inv_rect_Type2 hterm h1 = + let hcut = prog_params_rect_Type2 h1 hterm in hcut __ + +(** val prog_params_inv_rect_Type1 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 **) +let prog_params_inv_rect_Type1 hterm h1 = + let hcut = prog_params_rect_Type1 h1 hterm in hcut __ + +(** val prog_params_inv_rect_Type0 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 **) +let prog_params_inv_rect_Type0 hterm h1 = + let hcut = prog_params_rect_Type0 h1 hterm in hcut __ + +(** val prog_params_jmdiscr : prog_params -> prog_params -> __ **) +let prog_params_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { prog_spars = a0; prog = a1; stack_sizes = a2 } = x in + Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val prog_spars__o__spp' : + prog_params -> Joint_semantics.serialized_params **) +let prog_spars__o__spp' x0 = + x0.prog_spars.Joint_semantics.spp' + +(** val prog_spars__o__spp'__o__msu_pars : + prog_params -> Joint.joint_closed_internal_function + Joint_semantics.sem_unserialized_params **) +let prog_spars__o__spp'__o__msu_pars x0 = + Joint_semantics.spp'__o__msu_pars x0.prog_spars + +(** val prog_spars__o__spp'__o__msu_pars__o__st_pars : + prog_params -> Joint_semantics.sem_state_params **) +let prog_spars__o__spp'__o__msu_pars__o__st_pars x0 = + Joint_semantics.spp'__o__msu_pars__o__st_pars x0.prog_spars + +(** val prog_spars__o__spp'__o__spp : prog_params -> Joint.params **) +let prog_spars__o__spp'__o__spp x0 = + Joint_semantics.spp'__o__spp x0.prog_spars + +(** val prog_spars__o__spp'__o__spp__o__stmt_pars : + prog_params -> Joint.stmt_params **) +let prog_spars__o__spp'__o__spp__o__stmt_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars x0.prog_spars + +(** val prog_spars__o__spp'__o__spp__o__stmt_pars__o__uns_pars : + prog_params -> Joint.uns_params **) +let prog_spars__o__spp'__o__spp__o__stmt_pars__o__uns_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars__o__uns_pars x0.prog_spars + +(** val prog_spars__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + prog_params -> Joint.unserialized_params **) +let prog_spars__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars x0 = + Joint_semantics.spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars + x0.prog_spars + +(** val joint_make_global : prog_params -> evaluation_params **) +let joint_make_global p = + { globals = + (Joint.prog_names (Joint_semantics.spp'__o__spp p.prog_spars) p.prog); + ev_genv = + (SemanticsUtils.joint_globalenv p.prog_spars p.prog p.stack_sizes) } + +(** val joint_make_global__o__ev_genv : + prog_params -> Joint_semantics.genv **) +let joint_make_global__o__ev_genv x0 = + (joint_make_global x0).ev_genv + +(** val joint_make_global__o__ev_genv__o__ge : + prog_params -> Joint.joint_closed_internal_function AST.fundef + Globalenvs.genv_t **) +let joint_make_global__o__ev_genv__o__ge x0 = + ev_genv__o__ge x0.prog_spars (joint_make_global x0) + +(** val joint_make_global__o__ev_genv__o__ge__o__inject : + prog_params -> Joint.joint_closed_internal_function AST.fundef + Globalenvs.genv_t Types.sig0 **) +let joint_make_global__o__ev_genv__o__ge__o__inject x0 = + ev_genv__o__ge__o__inject x0.prog_spars (joint_make_global x0) + +(** val joint_make_global__o__ev_genv__o__inject : + prog_params -> Joint_semantics.genv Types.sig0 **) +let joint_make_global__o__ev_genv__o__inject x0 = + ev_genv__o__inject x0.prog_spars (joint_make_global x0) + +(** val joint_make_global__o__inject : + prog_params -> evaluation_params Types.sig0 **) +let joint_make_global__o__inject x0 = + joint_make_global x0 + +(** val make_initial_state : + prog_params -> Joint_semantics.state_pc Errors.res **) +let make_initial_state pars = + let p = pars.prog in + let ge = ev_genv pars.prog_spars in + Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic (Globalenvs.init_mem (fun x -> x) p.Joint.joint_prog)) + (fun m0 -> + (let { Types.fst = m; Types.snd = spb } = + GenMem.alloc m0 (Z.z_of_nat Nat.O) I8051bis.external_ram_size + in + (fun _ -> + let globals_size = + Joint.globals_stacksize + (Joint_semantics.spp'__o__spp pars.prog_spars) p + in + let spp = { Pointers.pblock = spb; Pointers.poff = + (BitVectorZ.bitvector_of_Z (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S + (Nat.S Nat.O)))))))))))))))) + (Z.zopp (Z.z_of_nat (Nat.S globals_size)))) } + in + let main = p.Joint.joint_prog.AST.prog_main in + let st = { Joint_semantics.st_frms = (Types.Some + (prog_spars__o__spp'__o__msu_pars__o__st_pars pars).Joint_semantics.empty_framesT); + Joint_semantics.istack = Joint_semantics.Empty_is; + Joint_semantics.carry = (ByteValues.BBbit Bool.False); + Joint_semantics.regs = + ((prog_spars__o__spp'__o__msu_pars__o__st_pars pars).Joint_semantics.empty_regsT + spp); Joint_semantics.m = m; Joint_semantics.stack_usage = + globals_size } + in + Monad.m_return0 (Monad.max_def Errors.res0) + { Joint_semantics.st_no_pc = + (Joint_semantics.set_sp + (prog_spars__o__spp'__o__msu_pars__o__st_pars pars) spp st); + Joint_semantics.pc = Joint_semantics.init_pc; + Joint_semantics.last_pop = (Joint_semantics.null_pc Positive.One) })) + __)) + +(** val joint_classify_step : + Joint.unserialized_params -> AST.ident List.list -> Joint.joint_step -> + StructuredTraces.status_class **) +let joint_classify_step p g = function +| Joint.COST_LABEL x -> StructuredTraces.Cl_other +| Joint.CALL (f, args, dest) -> StructuredTraces.Cl_call +| Joint.COND (x, x0) -> StructuredTraces.Cl_jump +| Joint.Step_seq x -> StructuredTraces.Cl_other + +(** val joint_classify_final : + Joint.unserialized_params -> Joint.joint_fin_step -> + StructuredTraces.status_class **) +let joint_classify_final p = function +| Joint.GOTO x -> StructuredTraces.Cl_other +| Joint.RETURN -> StructuredTraces.Cl_return +| Joint.TAILCALL (f, args) -> StructuredTraces.Cl_tailcall + +(** val joint_classify : + Joint_semantics.sem_params -> evaluation_params -> + Joint_semantics.state_pc -> StructuredTraces.status_class **) +let joint_classify p pars st = + match Joint_semantics.fetch_statement p pars.globals pars.ev_genv + st.Joint_semantics.pc with + | Errors.OK i_fn_s -> + (match i_fn_s.Types.snd with + | Joint.Sequential (s, x) -> + joint_classify_step + (Joint.uns_pars__o__u_pars + (Joint_semantics.spp'__o__spp__o__stmt_pars p)) pars.globals s + | Joint.Final s -> + joint_classify_final + (Joint.uns_pars__o__u_pars + (Joint_semantics.spp'__o__spp__o__stmt_pars p)) s + | Joint.FCOND (x0, x1, x2) -> StructuredTraces.Cl_jump) + | Errors.Error x -> StructuredTraces.Cl_other + +(** val joint_call_ident : + Joint_semantics.sem_params -> evaluation_params -> + Joint_semantics.state_pc -> AST.ident **) +let joint_call_ident p pars st = + let dummy = Positive.One in + (match Joint_semantics.fetch_statement p pars.globals pars.ev_genv + st.Joint_semantics.pc with + | Errors.OK x -> + (match x.Types.snd with + | Joint.Sequential (s, next) -> + (match s with + | Joint.COST_LABEL x0 -> dummy + | Joint.CALL (f', args, dest) -> + (match Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Joint_semantics.block_of_call p pars.globals + pars.ev_genv f' st.Joint_semantics.st_no_pc) + (fun bl -> + Obj.magic + (Joint_semantics.fetch_internal_function pars.globals + pars.ev_genv bl))) with + | Errors.OK i_f -> i_f.Types.fst + | Errors.Error x0 -> dummy) + | Joint.COND (x0, x1) -> dummy + | Joint.Step_seq x0 -> dummy) + | Joint.Final x0 -> dummy + | Joint.FCOND (x0, x1, x2) -> dummy) + | Errors.Error x -> dummy) + +(** val joint_tailcall_ident : + Joint_semantics.sem_params -> evaluation_params -> + Joint_semantics.state_pc -> AST.ident **) +let joint_tailcall_ident p pars st = + let dummy = Positive.One in + (match Joint_semantics.fetch_statement p pars.globals pars.ev_genv + st.Joint_semantics.pc with + | Errors.OK x -> + (match x.Types.snd with + | Joint.Sequential (x0, x1) -> dummy + | Joint.Final s -> + (match s with + | Joint.GOTO x0 -> dummy + | Joint.RETURN -> dummy + | Joint.TAILCALL (f', args) -> + (match Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Joint_semantics.block_of_call p pars.globals + pars.ev_genv f' st.Joint_semantics.st_no_pc) + (fun bl -> + Obj.magic + (Joint_semantics.fetch_internal_function pars.globals + pars.ev_genv bl))) with + | Errors.OK i_f -> i_f.Types.fst + | Errors.Error x0 -> dummy)) + | Joint.FCOND (x0, x1, x2) -> dummy) + | Errors.Error x -> dummy) + +(** val pcDeq : Deqsets.deqSet **) +let pcDeq = + Obj.magic ByteValues.eq_program_counter + +(** val cost_label_of_stmt : + Joint.stmt_params -> AST.ident List.list -> Joint.joint_statement -> + CostLabel.costlabel Types.option **) +let cost_label_of_stmt p g = function +| Joint.Sequential (s0, x) -> + (match s0 with + | Joint.COST_LABEL lbl -> Types.Some lbl + | Joint.CALL (x0, x1, x2) -> Types.None + | Joint.COND (x0, x1) -> Types.None + | Joint.Step_seq x0 -> Types.None) +| Joint.Final x -> Types.None +| Joint.FCOND (x0, x1, x2) -> Types.None + +(** val joint_label_of_pc : + Joint_semantics.sem_params -> evaluation_params -> + ByteValues.program_counter -> CostLabel.costlabel Types.option **) +let joint_label_of_pc p pars pc = + match Joint_semantics.fetch_statement p pars.globals pars.ev_genv pc with + | Errors.OK fn_stmt -> + cost_label_of_stmt (Joint_semantics.spp'__o__spp__o__stmt_pars p) + pars.globals fn_stmt.Types.snd + | Errors.Error x -> Types.None + +(** val exit_pc' : ByteValues.program_counter **) +let exit_pc' = + { ByteValues.pc_block = (Z.zopp (Z.z_of_nat (Nat.S Nat.O))); + ByteValues.pc_offset = (Positive.P1 Positive.One) } + +(** val joint_final : + Joint_semantics.sem_params -> evaluation_params -> + Joint_semantics.state_pc -> Integers.int Types.option **) +let joint_final p pars st = + let ge = pars.ev_genv in + (match ByteValues.eq_program_counter st.Joint_semantics.pc exit_pc' with + | Bool.True -> + let ret = + (Joint_semantics.spp'__o__msu_pars p).Joint_semantics.call_dest_for_main + in + (match Obj.magic + (Monad.m_bind0 (Monad.max_def Errors.res0) + (Obj.magic + (p.Joint_semantics.spp'.Joint_semantics.msu_pars.Joint_semantics.read_result + pars.globals ge.Joint_semantics.ge ret + st.Joint_semantics.st_no_pc)) (fun vals -> + Obj.magic (ByteValues.word_of_list_beval vals))) with + | Errors.OK v -> Types.Some v + | Errors.Error x -> Types.Some (BitVector.maximum Integers.wordsize)) + | Bool.False -> Types.None) + +(** val joint_abstract_status : + prog_params -> StructuredTraces.abstract_status **) +let joint_abstract_status p = + { StructuredTraces.as_pc = pcDeq; StructuredTraces.as_pc_of = + (Obj.magic + (Joint_semantics.pc (prog_spars__o__spp'__o__msu_pars__o__st_pars p))); + StructuredTraces.as_classify = + (Obj.magic (joint_classify p.prog_spars (joint_make_global p))); + StructuredTraces.as_label_of_pc = + (Obj.magic (joint_label_of_pc p.prog_spars (joint_make_global p))); + StructuredTraces.as_result = + (Obj.magic (joint_final p.prog_spars (joint_make_global p))); + StructuredTraces.as_call_ident = (fun st -> + joint_call_ident p.prog_spars (joint_make_global p) + (Types.pi1 (Obj.magic st))); StructuredTraces.as_tailcall_ident = + (fun st -> + joint_tailcall_ident p.prog_spars (joint_make_global p) + (Types.pi1 (Obj.magic st))) } + +(** val joint_status : + Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> + Nat.nat Types.option) -> StructuredTraces.abstract_status **) +let joint_status p prog0 stacksizes = + joint_abstract_status { prog_spars = p; prog = prog0; stack_sizes = + stacksizes } + diff --git a/extracted/traces.mli b/extracted/traces.mli new file mode 100644 index 0000000..9ee836d --- /dev/null +++ b/extracted/traces.mli @@ -0,0 +1,396 @@ +open Preamble + +open ExtraMonads + +open Deqsets_extra + +open State + +open Bind_new + +open BindLists + +open Blocks + +open TranslateUtils + +open ExtraGlobalenvs + +open I8051bis + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open BackEndOps + +open Joint + +open BEMem + +open CostLabel + +open Events + +open IOMonad + +open IO + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open Hide + +open ByteValues + +open Division + +open Z + +open BitVectorZ + +open Pointers + +open GenMem + +open FrontEndMem + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Extranat + +open Integers + +open AST + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Jmeq + +open Russell + +open Positive + +open PreIdentifiers + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Errors + +open Globalenvs + +open Joint_semantics + +open SemanticsUtils + +open StructuredTraces + +type evaluation_params = { globals : AST.ident List.list; + ev_genv : Joint_semantics.genv } + +val evaluation_params_rect_Type4 : + Joint_semantics.sem_params -> (AST.ident List.list -> Joint_semantics.genv + -> 'a1) -> evaluation_params -> 'a1 + +val evaluation_params_rect_Type5 : + Joint_semantics.sem_params -> (AST.ident List.list -> Joint_semantics.genv + -> 'a1) -> evaluation_params -> 'a1 + +val evaluation_params_rect_Type3 : + Joint_semantics.sem_params -> (AST.ident List.list -> Joint_semantics.genv + -> 'a1) -> evaluation_params -> 'a1 + +val evaluation_params_rect_Type2 : + Joint_semantics.sem_params -> (AST.ident List.list -> Joint_semantics.genv + -> 'a1) -> evaluation_params -> 'a1 + +val evaluation_params_rect_Type1 : + Joint_semantics.sem_params -> (AST.ident List.list -> Joint_semantics.genv + -> 'a1) -> evaluation_params -> 'a1 + +val evaluation_params_rect_Type0 : + Joint_semantics.sem_params -> (AST.ident List.list -> Joint_semantics.genv + -> 'a1) -> evaluation_params -> 'a1 + +val globals : + Joint_semantics.sem_params -> evaluation_params -> AST.ident List.list + +val ev_genv : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.genv + +val evaluation_params_inv_rect_Type4 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list -> + Joint_semantics.genv -> __ -> 'a1) -> 'a1 + +val evaluation_params_inv_rect_Type3 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list -> + Joint_semantics.genv -> __ -> 'a1) -> 'a1 + +val evaluation_params_inv_rect_Type2 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list -> + Joint_semantics.genv -> __ -> 'a1) -> 'a1 + +val evaluation_params_inv_rect_Type1 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list -> + Joint_semantics.genv -> __ -> 'a1) -> 'a1 + +val evaluation_params_inv_rect_Type0 : + Joint_semantics.sem_params -> evaluation_params -> (AST.ident List.list -> + Joint_semantics.genv -> __ -> 'a1) -> 'a1 + +val evaluation_params_discr : + Joint_semantics.sem_params -> evaluation_params -> evaluation_params -> __ + +val evaluation_params_jmdiscr : + Joint_semantics.sem_params -> evaluation_params -> evaluation_params -> __ + +val dpi1__o__ev_genv__o__inject : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint_semantics.genv Types.sig0 + +val dpi1__o__ev_genv__o__ge__o__inject : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + Types.sig0 + +val dpi1__o__ev_genv__o__ge : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + +val eject__o__ev_genv__o__inject : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint_semantics.genv Types.sig0 + +val eject__o__ev_genv__o__ge__o__inject : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + Types.sig0 + +val eject__o__ev_genv__o__ge : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + +val ev_genv__o__ge : + Joint_semantics.sem_params -> evaluation_params -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + +val ev_genv__o__ge__o__inject : + Joint_semantics.sem_params -> evaluation_params -> + Joint.joint_closed_internal_function AST.fundef Globalenvs.genv_t + Types.sig0 + +val ev_genv__o__inject : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.genv + Types.sig0 + +val dpi1__o__ev_genv : + Joint_semantics.sem_params -> (evaluation_params, 'a1) Types.dPair -> + Joint_semantics.genv + +val eject__o__ev_genv : + Joint_semantics.sem_params -> evaluation_params Types.sig0 -> + Joint_semantics.genv + +type prog_params = { prog_spars : Joint_semantics.sem_params; + prog : Joint.joint_program; + stack_sizes : (AST.ident -> Nat.nat Types.option) } + +val prog_params_rect_Type4 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> 'a1) -> prog_params -> 'a1 + +val prog_params_rect_Type5 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> 'a1) -> prog_params -> 'a1 + +val prog_params_rect_Type3 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> 'a1) -> prog_params -> 'a1 + +val prog_params_rect_Type2 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> 'a1) -> prog_params -> 'a1 + +val prog_params_rect_Type1 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> 'a1) -> prog_params -> 'a1 + +val prog_params_rect_Type0 : + (Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> 'a1) -> prog_params -> 'a1 + +val prog_spars : prog_params -> Joint_semantics.sem_params + +val prog : prog_params -> Joint.joint_program + +val stack_sizes : prog_params -> AST.ident -> Nat.nat Types.option + +val prog_params_inv_rect_Type4 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 + +val prog_params_inv_rect_Type3 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 + +val prog_params_inv_rect_Type2 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 + +val prog_params_inv_rect_Type1 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 + +val prog_params_inv_rect_Type0 : + prog_params -> (Joint_semantics.sem_params -> Joint.joint_program -> + (AST.ident -> Nat.nat Types.option) -> __ -> 'a1) -> 'a1 + +val prog_params_jmdiscr : prog_params -> prog_params -> __ + +val prog_spars__o__spp' : prog_params -> Joint_semantics.serialized_params + +val prog_spars__o__spp'__o__msu_pars : + prog_params -> Joint.joint_closed_internal_function + Joint_semantics.sem_unserialized_params + +val prog_spars__o__spp'__o__msu_pars__o__st_pars : + prog_params -> Joint_semantics.sem_state_params + +val prog_spars__o__spp'__o__spp : prog_params -> Joint.params + +val prog_spars__o__spp'__o__spp__o__stmt_pars : + prog_params -> Joint.stmt_params + +val prog_spars__o__spp'__o__spp__o__stmt_pars__o__uns_pars : + prog_params -> Joint.uns_params + +val prog_spars__o__spp'__o__spp__o__stmt_pars__o__uns_pars__o__u_pars : + prog_params -> Joint.unserialized_params + +val joint_make_global : prog_params -> evaluation_params + +val joint_make_global__o__ev_genv : prog_params -> Joint_semantics.genv + +val joint_make_global__o__ev_genv__o__ge : + prog_params -> Joint.joint_closed_internal_function AST.fundef + Globalenvs.genv_t + +val joint_make_global__o__ev_genv__o__ge__o__inject : + prog_params -> Joint.joint_closed_internal_function AST.fundef + Globalenvs.genv_t Types.sig0 + +val joint_make_global__o__ev_genv__o__inject : + prog_params -> Joint_semantics.genv Types.sig0 + +val joint_make_global__o__inject : + prog_params -> evaluation_params Types.sig0 + +val make_initial_state : prog_params -> Joint_semantics.state_pc Errors.res + +val joint_classify_step : + Joint.unserialized_params -> AST.ident List.list -> Joint.joint_step -> + StructuredTraces.status_class + +val joint_classify_final : + Joint.unserialized_params -> Joint.joint_fin_step -> + StructuredTraces.status_class + +val joint_classify : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.state_pc + -> StructuredTraces.status_class + +val joint_call_ident : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.state_pc + -> AST.ident + +val joint_tailcall_ident : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.state_pc + -> AST.ident + +val pcDeq : Deqsets.deqSet + +val cost_label_of_stmt : + Joint.stmt_params -> AST.ident List.list -> Joint.joint_statement -> + CostLabel.costlabel Types.option + +val joint_label_of_pc : + Joint_semantics.sem_params -> evaluation_params -> + ByteValues.program_counter -> CostLabel.costlabel Types.option + +val exit_pc' : ByteValues.program_counter + +val joint_final : + Joint_semantics.sem_params -> evaluation_params -> Joint_semantics.state_pc + -> Integers.int Types.option + +val joint_abstract_status : prog_params -> StructuredTraces.abstract_status + +val joint_status : + Joint_semantics.sem_params -> Joint.joint_program -> (AST.ident -> Nat.nat + Types.option) -> StructuredTraces.abstract_status + diff --git a/extracted/translateUtils.ml b/extracted/translateUtils.ml new file mode 100644 index 0000000..1131eed --- /dev/null +++ b/extracted/translateUtils.ml @@ -0,0 +1,710 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open State + +open Bind_new + +open BindLists + +open Blocks + +open Deqsets_extra + +(** val fresh_label : + Joint.params -> AST.ident List.list -> Graphs.label + Monad.smax_def__o__monad **) +let fresh_label g_pars globals = + Obj.magic (fun def -> + let { Types.fst = r; Types.snd = luniverse } = + Identifiers.fresh PreIdentifiers.LabelTag def.Joint.joint_if_luniverse + in + { Types.fst = (Joint.set_luniverse g_pars globals def luniverse); + Types.snd = r }) + +(** val fresh_register : + Joint.params -> AST.ident List.list -> Registers.register + Monad.smax_def__o__monad **) +let fresh_register g_pars globals = + Obj.magic (fun def -> + let { Types.fst = r; Types.snd = runiverse } = + Identifiers.fresh PreIdentifiers.RegisterTag + def.Joint.joint_if_runiverse + in + { Types.fst = (Joint.set_runiverse g_pars globals def runiverse); + Types.snd = r }) + +(** val adds_graph_pre : + Joint.graph_params -> AST.ident List.list -> (Graphs.label -> 'a1 -> + Joint.joint_seq) -> 'a1 List.list -> Graphs.label -> Graphs.label + Monad.smax_def__o__monad **) +let rec adds_graph_pre g_pars globals pre_process insts src = + match insts with + | List.Nil -> Monad.m_return0 (Monad.smax_def State.state_monad) src + | List.Cons (i, rest) -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (fresh_label (Joint.graph_params_to_params g_pars) globals) (fun mid -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (adds_graph_pre g_pars globals pre_process rest mid) (fun dst -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (State.state_update + (Joint.add_graph g_pars globals src (Joint.Sequential + ((Joint.Step_seq (pre_process dst i)), (Obj.magic mid))))) + (fun x -> Monad.m_return0 (Monad.smax_def State.state_monad) dst))) + +(** val adds_graph_post : + Joint.graph_params -> AST.ident List.list -> Joint.joint_seq List.list -> + Graphs.label -> Graphs.label Monad.smax_def__o__monad **) +let rec adds_graph_post g_pars globals insts dst = + match insts with + | List.Nil -> Monad.m_return0 (Monad.smax_def State.state_monad) dst + | List.Cons (i, rest) -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (fresh_label (Joint.graph_params_to_params g_pars) globals) (fun src -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (adds_graph_post g_pars globals rest dst) (fun mid -> + Monad.m_bind0 (Monad.smax_def State.state_monad) + (State.state_update + (Joint.add_graph g_pars globals src (Joint.Sequential + ((Joint.Step_seq i), mid)))) (fun x -> + Monad.m_return0 (Monad.smax_def State.state_monad) src))) + +(** val adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.step_block -> + Graphs.label -> Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function **) +let adds_graph g_pars globals insts src dst def = + let pref = insts.Types.fst.Types.fst in + let op = insts.Types.fst.Types.snd in + let post = insts.Types.snd in + let { Types.fst = def0; Types.snd = mid } = + Obj.magic adds_graph_pre g_pars globals (fun lbl inst -> inst lbl) + (Obj.magic pref) src def + in + let { Types.fst = def1; Types.snd = mid' } = + Obj.magic adds_graph_post g_pars globals post dst def0 + in + Joint.add_graph g_pars globals mid (Joint.Sequential ((Obj.magic op mid), + mid')) def1 + +(** val fin_adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.fin_block -> + Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function **) +let fin_adds_graph g_pars globals insts src def = + let pref = insts.Types.fst in + let last = insts.Types.snd in + let { Types.fst = def0; Types.snd = mid } = + Obj.magic adds_graph_pre g_pars globals (fun x i -> i) pref src def + in + Joint.add_graph g_pars globals mid (Joint.Final last) def0 + +(** val b_adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.bind_step_block -> + Graphs.label -> Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function **) +let b_adds_graph g_pars globals insts src dst def = + let { Types.fst = def0; Types.snd = stmts } = + Obj.magic Bind_new.bcompile + (fresh_register (Joint.graph_params_to_params g_pars) globals) insts + def + in + adds_graph g_pars globals stmts src dst def0 + +(** val b_fin_adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.bind_fin_block -> + Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function **) +let b_fin_adds_graph g_pars globals insts src def = + let { Types.fst = def0; Types.snd = stmts } = + Obj.magic Bind_new.bcompile + (fresh_register (Joint.graph_params_to_params g_pars) globals) insts + def + in + fin_adds_graph g_pars globals stmts src def0 + +(** val step_registers : + Joint.uns_params -> AST.ident List.list -> Joint.joint_step -> + Registers.register List.list **) +let step_registers p globals s = + Joint.get_used_registers_from_step p.Joint.u_pars globals p.Joint.functs s + +(** val fin_step_registers : + Joint.uns_params -> Joint.joint_fin_step -> Registers.register List.list **) +let fin_step_registers p = function +| Joint.GOTO x -> List.Nil +| Joint.RETURN -> List.Nil +| Joint.TAILCALL (x0, r) -> p.Joint.functs.Joint.f_call_args r + +type b_graph_translate_data = { init_ret : __; init_params : __; + init_stack_size : Nat.nat; + added_prologue : Joint.joint_seq List.list; + new_regs : Registers.register List.list; + f_step : (Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block); + f_fin : (Graphs.label -> Joint.joint_fin_step + -> Blocks.bind_fin_block) } + +(** val b_graph_translate_data_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register + List.list -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) + -> (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ + -> __ -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 **) +let rec b_graph_translate_data_rect_Type4 src dst globals h_mk_b_graph_translate_data x_18277 = + let { init_ret = init_ret0; init_params = init_params0; init_stack_size = + init_stack_size0; added_prologue = added_prologue0; new_regs = new_regs0; + f_step = f_step0; f_fin = f_fin0 } = x_18277 + in + h_mk_b_graph_translate_data init_ret0 init_params0 init_stack_size0 + added_prologue0 new_regs0 f_step0 f_fin0 __ __ __ __ + +(** val b_graph_translate_data_rect_Type5 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register + List.list -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) + -> (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ + -> __ -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 **) +let rec b_graph_translate_data_rect_Type5 src dst globals h_mk_b_graph_translate_data x_18279 = + let { init_ret = init_ret0; init_params = init_params0; init_stack_size = + init_stack_size0; added_prologue = added_prologue0; new_regs = new_regs0; + f_step = f_step0; f_fin = f_fin0 } = x_18279 + in + h_mk_b_graph_translate_data init_ret0 init_params0 init_stack_size0 + added_prologue0 new_regs0 f_step0 f_fin0 __ __ __ __ + +(** val b_graph_translate_data_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register + List.list -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) + -> (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ + -> __ -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 **) +let rec b_graph_translate_data_rect_Type3 src dst globals h_mk_b_graph_translate_data x_18281 = + let { init_ret = init_ret0; init_params = init_params0; init_stack_size = + init_stack_size0; added_prologue = added_prologue0; new_regs = new_regs0; + f_step = f_step0; f_fin = f_fin0 } = x_18281 + in + h_mk_b_graph_translate_data init_ret0 init_params0 init_stack_size0 + added_prologue0 new_regs0 f_step0 f_fin0 __ __ __ __ + +(** val b_graph_translate_data_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register + List.list -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) + -> (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ + -> __ -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 **) +let rec b_graph_translate_data_rect_Type2 src dst globals h_mk_b_graph_translate_data x_18283 = + let { init_ret = init_ret0; init_params = init_params0; init_stack_size = + init_stack_size0; added_prologue = added_prologue0; new_regs = new_regs0; + f_step = f_step0; f_fin = f_fin0 } = x_18283 + in + h_mk_b_graph_translate_data init_ret0 init_params0 init_stack_size0 + added_prologue0 new_regs0 f_step0 f_fin0 __ __ __ __ + +(** val b_graph_translate_data_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register + List.list -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) + -> (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ + -> __ -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 **) +let rec b_graph_translate_data_rect_Type1 src dst globals h_mk_b_graph_translate_data x_18285 = + let { init_ret = init_ret0; init_params = init_params0; init_stack_size = + init_stack_size0; added_prologue = added_prologue0; new_regs = new_regs0; + f_step = f_step0; f_fin = f_fin0 } = x_18285 + in + h_mk_b_graph_translate_data init_ret0 init_params0 init_stack_size0 + added_prologue0 new_regs0 f_step0 f_fin0 __ __ __ __ + +(** val b_graph_translate_data_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register + List.list -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) + -> (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ + -> __ -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 **) +let rec b_graph_translate_data_rect_Type0 src dst globals h_mk_b_graph_translate_data x_18287 = + let { init_ret = init_ret0; init_params = init_params0; init_stack_size = + init_stack_size0; added_prologue = added_prologue0; new_regs = new_regs0; + f_step = f_step0; f_fin = f_fin0 } = x_18287 + in + h_mk_b_graph_translate_data init_ret0 init_params0 init_stack_size0 + added_prologue0 new_regs0 f_step0 f_fin0 __ __ __ __ + +(** val init_ret : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> __ **) +let rec init_ret src dst globals xxx = + xxx.init_ret + +(** val init_params : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> __ **) +let rec init_params src dst globals xxx = + xxx.init_params + +(** val init_stack_size : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Nat.nat **) +let rec init_stack_size src dst globals xxx = + xxx.init_stack_size + +(** val added_prologue : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_seq List.list **) +let rec added_prologue src dst globals xxx = + xxx.added_prologue + +(** val new_regs : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Registers.register List.list **) +let rec new_regs src dst globals xxx = + xxx.new_regs + +(** val f_step : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block **) +let rec f_step src dst globals xxx = + xxx.f_step + +(** val f_fin : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block **) +let rec f_fin src dst globals xxx = + xxx.f_fin + +(** val b_graph_translate_data_inv_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq + List.list -> Registers.register List.list -> (Graphs.label -> + Joint.joint_step -> Blocks.bind_step_block) -> (Graphs.label -> + Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let b_graph_translate_data_inv_rect_Type4 x1 x2 x3 hterm h1 = + let hcut = b_graph_translate_data_rect_Type4 x1 x2 x3 h1 hterm in hcut __ + +(** val b_graph_translate_data_inv_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq + List.list -> Registers.register List.list -> (Graphs.label -> + Joint.joint_step -> Blocks.bind_step_block) -> (Graphs.label -> + Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let b_graph_translate_data_inv_rect_Type3 x1 x2 x3 hterm h1 = + let hcut = b_graph_translate_data_rect_Type3 x1 x2 x3 h1 hterm in hcut __ + +(** val b_graph_translate_data_inv_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq + List.list -> Registers.register List.list -> (Graphs.label -> + Joint.joint_step -> Blocks.bind_step_block) -> (Graphs.label -> + Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let b_graph_translate_data_inv_rect_Type2 x1 x2 x3 hterm h1 = + let hcut = b_graph_translate_data_rect_Type2 x1 x2 x3 h1 hterm in hcut __ + +(** val b_graph_translate_data_inv_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq + List.list -> Registers.register List.list -> (Graphs.label -> + Joint.joint_step -> Blocks.bind_step_block) -> (Graphs.label -> + Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let b_graph_translate_data_inv_rect_Type1 x1 x2 x3 hterm h1 = + let hcut = b_graph_translate_data_rect_Type1 x1 x2 x3 h1 hterm in hcut __ + +(** val b_graph_translate_data_inv_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq + List.list -> Registers.register List.list -> (Graphs.label -> + Joint.joint_step -> Blocks.bind_step_block) -> (Graphs.label -> + Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> + __ -> 'a1) -> 'a1 **) +let b_graph_translate_data_inv_rect_Type0 x1 x2 x3 hterm h1 = + let hcut = b_graph_translate_data_rect_Type0 x1 x2 x3 h1 hterm in hcut __ + +(** val b_graph_translate_data_jmdiscr : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> b_graph_translate_data -> __ **) +let b_graph_translate_data_jmdiscr a1 a2 a3 x y = + Logic.eq_rect_Type2 x + (let { init_ret = a0; init_params = a10; init_stack_size = a20; + added_prologue = a30; new_regs = a4; f_step = a5; f_fin = a6 } = x + in + Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __)) y + +type bound_b_graph_translate_data = + (Registers.register, b_graph_translate_data) Bind_new.bind_new Types.sig0 + +(** val get_first_costlabel_next : + Joint.params -> AST.ident List.list -> + Joint.joint_closed_internal_function -> (CostLabel.costlabel, __) + Types.prod **) +let get_first_costlabel_next p g def = + (match p.Joint.stmt_at g (Types.pi1 def).Joint.joint_if_code + (Types.pi1 def).Joint.joint_if_entry with + | Types.None -> (fun _ -> assert false (* absurd case *)) + | Types.Some s -> + (match s with + | Joint.Sequential (s', nxt) -> + (match s' with + | Joint.COST_LABEL c -> + (fun _ -> { Types.fst = c; Types.snd = nxt }) + | Joint.CALL (x, x0, x1) -> + (fun _ -> assert false (* absurd case *)) + | Joint.COND (x, x0) -> (fun _ -> assert false (* absurd case *)) + | Joint.Step_seq x -> (fun _ -> assert false (* absurd case *))) + | Joint.Final x -> (fun _ -> assert false (* absurd case *)) + | Joint.FCOND (x0, x1, x2) -> (fun _ -> assert false (* absurd case *)))) + __ + +(** val get_first_costlabel : + Joint.params -> AST.ident List.list -> + Joint.joint_closed_internal_function -> CostLabel.costlabel **) +let get_first_costlabel p g f = + (get_first_costlabel_next p g f).Types.fst + +(** val not_emptyb : 'a1 List.list -> Bool.bool **) +let not_emptyb = function +| List.Nil -> Bool.False +| List.Cons (x, x0) -> Bool.True + +(** val b_graph_translate_props_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec b_graph_translate_props_rect_Type4 src_g_pars dst_g_pars globals data def_in def_out f_lbls f_regs h_mk_b_graph_translate_props = + h_mk_b_graph_translate_props __ __ __ __ __ __ __ __ __ __ __ + +(** val b_graph_translate_props_rect_Type5 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec b_graph_translate_props_rect_Type5 src_g_pars dst_g_pars globals data def_in def_out f_lbls f_regs h_mk_b_graph_translate_props = + h_mk_b_graph_translate_props __ __ __ __ __ __ __ __ __ __ __ + +(** val b_graph_translate_props_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec b_graph_translate_props_rect_Type3 src_g_pars dst_g_pars globals data def_in def_out f_lbls f_regs h_mk_b_graph_translate_props = + h_mk_b_graph_translate_props __ __ __ __ __ __ __ __ __ __ __ + +(** val b_graph_translate_props_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec b_graph_translate_props_rect_Type2 src_g_pars dst_g_pars globals data def_in def_out f_lbls f_regs h_mk_b_graph_translate_props = + h_mk_b_graph_translate_props __ __ __ __ __ __ __ __ __ __ __ + +(** val b_graph_translate_props_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec b_graph_translate_props_rect_Type1 src_g_pars dst_g_pars globals data def_in def_out f_lbls f_regs h_mk_b_graph_translate_props = + h_mk_b_graph_translate_props __ __ __ __ __ __ __ __ __ __ __ + +(** val b_graph_translate_props_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 **) +let rec b_graph_translate_props_rect_Type0 src_g_pars dst_g_pars globals data def_in def_out f_lbls f_regs h_mk_b_graph_translate_props = + h_mk_b_graph_translate_props __ __ __ __ __ __ __ __ __ __ __ + +(** val b_graph_translate_props_inv_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let b_graph_translate_props_inv_rect_Type4 x1 x2 x3 x4 x5 x6 x7 x8 h1 = + let hcut = b_graph_translate_props_rect_Type4 x1 x2 x3 x4 x5 x6 x7 x8 h1 in + hcut __ + +(** val b_graph_translate_props_inv_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let b_graph_translate_props_inv_rect_Type3 x1 x2 x3 x4 x5 x6 x7 x8 h1 = + let hcut = b_graph_translate_props_rect_Type3 x1 x2 x3 x4 x5 x6 x7 x8 h1 in + hcut __ + +(** val b_graph_translate_props_inv_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let b_graph_translate_props_inv_rect_Type2 x1 x2 x3 x4 x5 x6 x7 x8 h1 = + let hcut = b_graph_translate_props_rect_Type2 x1 x2 x3 x4 x5 x6 x7 x8 h1 in + hcut __ + +(** val b_graph_translate_props_inv_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let b_graph_translate_props_inv_rect_Type1 x1 x2 x3 x4 x5 x6 x7 x8 h1 = + let hcut = b_graph_translate_props_rect_Type1 x1 x2 x3 x4 x5 x6 x7 x8 h1 in + hcut __ + +(** val b_graph_translate_props_inv_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> + 'a1 **) +let b_graph_translate_props_inv_rect_Type0 x1 x2 x3 x4 x5 x6 x7 x8 h1 = + let hcut = b_graph_translate_props_rect_Type0 x1 x2 x3 x4 x5 x6 x7 x8 h1 in + hcut __ + +(** val b_graph_translate_props_jmdiscr : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> __ **) +let b_graph_translate_props_jmdiscr a1 a2 a3 a4 a5 a6 a7 a8 = + Logic.eq_rect_Type2 __ + (Obj.magic (fun _ dH -> dH __ __ __ __ __ __ __ __ __ __ __)) __ + +(** val pair_swap : ('a1, 'a2) Types.prod -> ('a2, 'a1) Types.prod **) +let pair_swap pr = + { Types.fst = pr.Types.snd; Types.snd = pr.Types.fst } + +(** val set_entry : + AST.ident List.list -> Joint.params -> Joint.joint_internal_function -> + __ -> Joint.joint_internal_function **) +let set_entry globals pars int_fun entry = + { Joint.joint_if_luniverse = int_fun.Joint.joint_if_luniverse; + Joint.joint_if_runiverse = int_fun.Joint.joint_if_runiverse; + Joint.joint_if_result = int_fun.Joint.joint_if_result; + Joint.joint_if_params = int_fun.Joint.joint_if_params; + Joint.joint_if_stacksize = int_fun.Joint.joint_if_stacksize; + Joint.joint_if_local_stacksize = int_fun.Joint.joint_if_local_stacksize; + Joint.joint_if_code = int_fun.Joint.joint_if_code; Joint.joint_if_entry = + entry } + +(** val b_graph_translate : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + bound_b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function Types.sig0 **) +let b_graph_translate src_g_pars dst_g_pars globals data def = + let runiv_data = + Obj.magic Bind_new.bcompile + (Obj.magic + (Relations.compose pair_swap + (Identifiers.fresh PreIdentifiers.RegisterTag))) (Types.pi1 data) + (Types.pi1 def).Joint.joint_if_runiverse + in + let runiv = runiv_data.Types.fst in + let data0 = runiv_data.Types.snd in + let entry = (Types.pi1 def).Joint.joint_if_entry in + let init = { Joint.joint_if_luniverse = + (Types.pi1 def).Joint.joint_if_luniverse; Joint.joint_if_runiverse = + runiv; Joint.joint_if_result = data0.init_ret; Joint.joint_if_params = + data0.init_params; Joint.joint_if_stacksize = data0.init_stack_size; + Joint.joint_if_local_stacksize = + (Types.pi1 def).Joint.joint_if_local_stacksize; Joint.joint_if_code = + (Obj.magic (Identifiers.empty_map PreIdentifiers.LabelTag)); + Joint.joint_if_entry = entry } + in + let f = fun lbl stmt def0 -> + match stmt with + | Joint.Sequential (inst, next) -> + b_adds_graph dst_g_pars globals (data0.f_step lbl inst) lbl + (Obj.magic next) def0 + | Joint.Final inst -> + b_fin_adds_graph dst_g_pars globals (data0.f_fin lbl inst) lbl def0 + | Joint.FCOND (x, x0, x1) -> assert false (* absurd case *) + in + let def_out = + Identifiers.foldi PreIdentifiers.LabelTag f + (Obj.magic (Types.pi1 def).Joint.joint_if_code) init + in + let prologue = data0.added_prologue in + let def_out0 = + match not_emptyb prologue with + | Bool.True -> + let { Types.fst = init_c; Types.snd = nxt } = + get_first_costlabel_next (Joint.graph_params_to_params src_g_pars) + globals def + in + let def_out0 = + Joint.add_graph dst_g_pars globals (Obj.magic entry) + (Joint.Sequential ((Joint.Step_seq + (Joint.nOOP + (Joint.uns_pars__o__u_pars + (Joint.gp_to_p__o__stmt_pars dst_g_pars)) globals)), nxt)) + def_out + in + let { Types.fst = def_out1; Types.snd = entry' } = + Obj.magic fresh_label (Joint.graph_params_to_params dst_g_pars) + globals def_out0 + in + let def_out2 = + adds_graph dst_g_pars globals { Types.fst = { Types.fst = List.Nil; + Types.snd = (fun x -> Joint.COST_LABEL init_c) }; Types.snd = + prologue } entry' (Obj.magic entry) def_out1 + in + set_entry globals (Joint.graph_params_to_params dst_g_pars) def_out2 + (Obj.magic entry') + | Bool.False -> def_out + in + def_out0 + +(** val b_graph_transform_program : + Joint.graph_params -> Joint.graph_params -> (AST.ident List.list -> + Joint.joint_closed_internal_function -> bound_b_graph_translate_data) -> + Joint.joint_program -> Joint.joint_program **) +let b_graph_transform_program src dst init = + Joint.transform_joint_program (Joint.graph_params_to_params src) + (Joint.graph_params_to_params dst) (fun varnames def_in -> + Types.pi1 + (b_graph_translate src dst varnames (init varnames def_in) def_in)) + +(** val added_registers : + Joint.graph_params -> AST.ident List.list -> + Joint.joint_internal_function -> (Graphs.label -> Registers.register + List.list) -> Registers.register List.list **) +let added_registers p g def f_regs = + let f = fun lbl x acc -> List.append (f_regs lbl) acc in + Identifiers.foldi PreIdentifiers.LabelTag f + (Obj.magic def.Joint.joint_if_code) List.Nil + diff --git a/extracted/translateUtils.mli b/extracted/translateUtils.mli new file mode 100644 index 0000000..926062e --- /dev/null +++ b/extracted/translateUtils.mli @@ -0,0 +1,411 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open State + +open Bind_new + +open BindLists + +open Blocks + +open Deqsets_extra + +val fresh_label : + Joint.params -> AST.ident List.list -> Graphs.label + Monad.smax_def__o__monad + +val fresh_register : + Joint.params -> AST.ident List.list -> Registers.register + Monad.smax_def__o__monad + +val adds_graph_pre : + Joint.graph_params -> AST.ident List.list -> (Graphs.label -> 'a1 -> + Joint.joint_seq) -> 'a1 List.list -> Graphs.label -> Graphs.label + Monad.smax_def__o__monad + +val adds_graph_post : + Joint.graph_params -> AST.ident List.list -> Joint.joint_seq List.list -> + Graphs.label -> Graphs.label Monad.smax_def__o__monad + +val adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.step_block -> + Graphs.label -> Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function + +val fin_adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.fin_block -> + Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function + +val b_adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.bind_step_block -> + Graphs.label -> Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function + +val b_fin_adds_graph : + Joint.graph_params -> AST.ident List.list -> Blocks.bind_fin_block -> + Graphs.label -> Joint.joint_internal_function -> + Joint.joint_internal_function + +val step_registers : + Joint.uns_params -> AST.ident List.list -> Joint.joint_step -> + Registers.register List.list + +val fin_step_registers : + Joint.uns_params -> Joint.joint_fin_step -> Registers.register List.list + +type b_graph_translate_data = { init_ret : __; init_params : __; + init_stack_size : Nat.nat; + added_prologue : Joint.joint_seq List.list; + new_regs : Registers.register List.list; + f_step : (Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block); + f_fin : (Graphs.label -> Joint.joint_fin_step + -> Blocks.bind_fin_block) } + +val b_graph_translate_data_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register List.list + -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) -> + (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ + -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 + +val b_graph_translate_data_rect_Type5 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register List.list + -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) -> + (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ + -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 + +val b_graph_translate_data_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register List.list + -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) -> + (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ + -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 + +val b_graph_translate_data_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register List.list + -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) -> + (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ + -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 + +val b_graph_translate_data_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register List.list + -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) -> + (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ + -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 + +val b_graph_translate_data_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> (__ -> + __ -> Nat.nat -> Joint.joint_seq List.list -> Registers.register List.list + -> (Graphs.label -> Joint.joint_step -> Blocks.bind_step_block) -> + (Graphs.label -> Joint.joint_fin_step -> Blocks.bind_fin_block) -> __ -> __ + -> __ -> __ -> 'a1) -> b_graph_translate_data -> 'a1 + +val init_ret : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> __ + +val init_params : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> __ + +val init_stack_size : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Nat.nat + +val added_prologue : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_seq List.list + +val new_regs : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Registers.register List.list + +val f_step : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block + +val f_fin : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block + +val b_graph_translate_data_inv_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq List.list + -> Registers.register List.list -> (Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block) -> (Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_data_inv_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq List.list + -> Registers.register List.list -> (Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block) -> (Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_data_inv_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq List.list + -> Registers.register List.list -> (Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block) -> (Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_data_inv_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq List.list + -> Registers.register List.list -> (Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block) -> (Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_data_inv_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> (__ -> __ -> Nat.nat -> Joint.joint_seq List.list + -> Registers.register List.list -> (Graphs.label -> Joint.joint_step -> + Blocks.bind_step_block) -> (Graphs.label -> Joint.joint_fin_step -> + Blocks.bind_fin_block) -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_data_jmdiscr : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> b_graph_translate_data -> __ + +type bound_b_graph_translate_data = + (Registers.register, b_graph_translate_data) Bind_new.bind_new Types.sig0 + +val get_first_costlabel_next : + Joint.params -> AST.ident List.list -> Joint.joint_closed_internal_function + -> (CostLabel.costlabel, __) Types.prod + +val get_first_costlabel : + Joint.params -> AST.ident List.list -> Joint.joint_closed_internal_function + -> CostLabel.costlabel + +val not_emptyb : 'a1 List.list -> Bool.bool + +val b_graph_translate_props_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_rect_Type5 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_inv_rect_Type4 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_inv_rect_Type3 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_inv_rect_Type2 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_inv_rect_Type1 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_inv_rect_Type0 : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> (__ -> __ + -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> __ -> 'a1) -> 'a1 + +val b_graph_translate_props_jmdiscr : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function -> (Graphs.label -> Graphs.label + List.list) -> (Graphs.label -> Registers.register List.list) -> __ + +val pair_swap : ('a1, 'a2) Types.prod -> ('a2, 'a1) Types.prod + +val set_entry : + AST.ident List.list -> Joint.params -> Joint.joint_internal_function -> __ + -> Joint.joint_internal_function + +val b_graph_translate : + Joint.graph_params -> Joint.graph_params -> AST.ident List.list -> + bound_b_graph_translate_data -> Joint.joint_closed_internal_function -> + Joint.joint_closed_internal_function Types.sig0 + +val b_graph_transform_program : + Joint.graph_params -> Joint.graph_params -> (AST.ident List.list -> + Joint.joint_closed_internal_function -> bound_b_graph_translate_data) -> + Joint.joint_program -> Joint.joint_program + +val added_registers : + Joint.graph_params -> AST.ident List.list -> Joint.joint_internal_function + -> (Graphs.label -> Registers.register List.list) -> Registers.register + List.list + diff --git a/extracted/typeComparison.ml b/extracted/typeComparison.ml new file mode 100644 index 0000000..a45da25 --- /dev/null +++ b/extracted/typeComparison.ml @@ -0,0 +1,289 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +(** val sz_eq_dec : AST.intsize -> AST.intsize -> (__, __) Types.sum **) +let sz_eq_dec = function +| AST.I8 -> + (fun s2 -> + match s2 with + | AST.I8 -> Types.Inl __ + | AST.I16 -> Types.Inr __ + | AST.I32 -> Types.Inr __) +| AST.I16 -> + (fun s2 -> + match s2 with + | AST.I8 -> Types.Inr __ + | AST.I16 -> Types.Inl __ + | AST.I32 -> Types.Inr __) +| AST.I32 -> + (fun s2 -> + match s2 with + | AST.I8 -> Types.Inr __ + | AST.I16 -> Types.Inr __ + | AST.I32 -> Types.Inl __) + +(** val sg_eq_dec : + AST.signedness -> AST.signedness -> (__, __) Types.sum **) +let sg_eq_dec = function +| AST.Signed -> + (fun s2 -> + match s2 with + | AST.Signed -> Types.Inl __ + | AST.Unsigned -> Types.Inr __) +| AST.Unsigned -> + (fun s2 -> + match s2 with + | AST.Signed -> Types.Inr __ + | AST.Unsigned -> Types.Inl __) + +(** val type_eq_dec : + Csyntax.type0 -> Csyntax.type0 -> (__, __) Types.sum **) +let rec type_eq_dec t1 t2 = + match t1 with + | Csyntax.Tvoid -> + (match t2 with + | Csyntax.Tvoid -> Types.Inl __ + | Csyntax.Tint (x, x0) -> Types.Inr __ + | Csyntax.Tpointer x -> Types.Inr __ + | Csyntax.Tarray (x, x0) -> Types.Inr __ + | Csyntax.Tfunction (x, x0) -> Types.Inr __ + | Csyntax.Tstruct (x, x0) -> Types.Inr __ + | Csyntax.Tunion (x, x0) -> Types.Inr __ + | Csyntax.Tcomp_ptr x -> Types.Inr __) + | Csyntax.Tint (sz, sg) -> + (match t2 with + | Csyntax.Tvoid -> Types.Inr __ + | Csyntax.Tint (sz', sg') -> + (match sz_eq_dec sz sz' with + | Types.Inl _ -> + (match sg_eq_dec sg sg' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __) + | Csyntax.Tpointer x -> Types.Inr __ + | Csyntax.Tarray (x, x0) -> Types.Inr __ + | Csyntax.Tfunction (x, x0) -> Types.Inr __ + | Csyntax.Tstruct (x, x0) -> Types.Inr __ + | Csyntax.Tunion (x, x0) -> Types.Inr __ + | Csyntax.Tcomp_ptr x -> Types.Inr __) + | Csyntax.Tpointer t -> + (match t2 with + | Csyntax.Tvoid -> Types.Inr __ + | Csyntax.Tint (x, x0) -> Types.Inr __ + | Csyntax.Tpointer t' -> + (match type_eq_dec t t' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Csyntax.Tarray (x, x0) -> Types.Inr __ + | Csyntax.Tfunction (x, x0) -> Types.Inr __ + | Csyntax.Tstruct (x, x0) -> Types.Inr __ + | Csyntax.Tunion (x, x0) -> Types.Inr __ + | Csyntax.Tcomp_ptr x -> Types.Inr __) + | Csyntax.Tarray (t, n) -> + (match t2 with + | Csyntax.Tvoid -> Types.Inr __ + | Csyntax.Tint (x, x0) -> Types.Inr __ + | Csyntax.Tpointer x -> Types.Inr __ + | Csyntax.Tarray (t', n') -> + (match type_eq_dec t t' with + | Types.Inl _ -> + (match Extranat.eq_nat_dec n n' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __) + | Csyntax.Tfunction (x, x0) -> Types.Inr __ + | Csyntax.Tstruct (x, x0) -> Types.Inr __ + | Csyntax.Tunion (x, x0) -> Types.Inr __ + | Csyntax.Tcomp_ptr x -> Types.Inr __) + | Csyntax.Tfunction (tl, t) -> + (match t2 with + | Csyntax.Tvoid -> Types.Inr __ + | Csyntax.Tint (x, x0) -> Types.Inr __ + | Csyntax.Tpointer x -> Types.Inr __ + | Csyntax.Tarray (x, x0) -> Types.Inr __ + | Csyntax.Tfunction (tl', t') -> + (match typelist_eq_dec tl tl' with + | Types.Inl _ -> + (match type_eq_dec t t' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __) + | Csyntax.Tstruct (x, x0) -> Types.Inr __ + | Csyntax.Tunion (x, x0) -> Types.Inr __ + | Csyntax.Tcomp_ptr x -> Types.Inr __) + | Csyntax.Tstruct (i, fl) -> + (match t2 with + | Csyntax.Tvoid -> Types.Inr __ + | Csyntax.Tint (x, x0) -> Types.Inr __ + | Csyntax.Tpointer x -> Types.Inr __ + | Csyntax.Tarray (x, x0) -> Types.Inr __ + | Csyntax.Tfunction (x, x0) -> Types.Inr __ + | Csyntax.Tstruct (i', fl') -> + (match AST.ident_eq i i' with + | Types.Inl _ -> + (match fieldlist_eq_dec fl fl' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __) + | Csyntax.Tunion (x, x0) -> Types.Inr __ + | Csyntax.Tcomp_ptr x -> Types.Inr __) + | Csyntax.Tunion (i, fl) -> + (match t2 with + | Csyntax.Tvoid -> Types.Inr __ + | Csyntax.Tint (x, x0) -> Types.Inr __ + | Csyntax.Tpointer x -> Types.Inr __ + | Csyntax.Tarray (x, x0) -> Types.Inr __ + | Csyntax.Tfunction (x, x0) -> Types.Inr __ + | Csyntax.Tstruct (x, x0) -> Types.Inr __ + | Csyntax.Tunion (i', fl') -> + (match AST.ident_eq i i' with + | Types.Inl _ -> + (match fieldlist_eq_dec fl fl' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __) + | Csyntax.Tcomp_ptr x -> Types.Inr __) + | Csyntax.Tcomp_ptr i -> + (match t2 with + | Csyntax.Tvoid -> Types.Inr __ + | Csyntax.Tint (x, x0) -> Types.Inr __ + | Csyntax.Tpointer x -> Types.Inr __ + | Csyntax.Tarray (x, x0) -> Types.Inr __ + | Csyntax.Tfunction (x, x0) -> Types.Inr __ + | Csyntax.Tstruct (x, x0) -> Types.Inr __ + | Csyntax.Tunion (x, x0) -> Types.Inr __ + | Csyntax.Tcomp_ptr i' -> + (match AST.ident_eq i i' with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __)) +(** val typelist_eq_dec : + Csyntax.typelist -> Csyntax.typelist -> (__, __) Types.sum **) +and typelist_eq_dec tl1 tl2 = + match tl1 with + | Csyntax.Tnil -> + (match tl2 with + | Csyntax.Tnil -> Types.Inl __ + | Csyntax.Tcons (x, x0) -> Types.Inr __) + | Csyntax.Tcons (t1, ts1) -> + (match tl2 with + | Csyntax.Tnil -> Types.Inr __ + | Csyntax.Tcons (t2, ts2) -> + (match type_eq_dec t1 t2 with + | Types.Inl _ -> + (match typelist_eq_dec ts1 ts2 with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __)) +(** val fieldlist_eq_dec : + Csyntax.fieldlist -> Csyntax.fieldlist -> (__, __) Types.sum **) +and fieldlist_eq_dec fl1 fl2 = + match fl1 with + | Csyntax.Fnil -> + (match fl2 with + | Csyntax.Fnil -> Types.Inl __ + | Csyntax.Fcons (x, x0, x1) -> Types.Inr __) + | Csyntax.Fcons (i1, t1, fs1) -> + (match fl2 with + | Csyntax.Fnil -> Types.Inr __ + | Csyntax.Fcons (i2, t2, fs2) -> + (match AST.ident_eq i1 i2 with + | Types.Inl _ -> + (match type_eq_dec t1 t2 with + | Types.Inl _ -> + (match fieldlist_eq_dec fs1 fs2 with + | Types.Inl _ -> Types.Inl __ + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __) + | Types.Inr _ -> Types.Inr __)) + +(** val assert_type_eq : Csyntax.type0 -> Csyntax.type0 -> __ Errors.res **) +let assert_type_eq t1 t2 = + match type_eq_dec t1 t2 with + | Types.Inl _ -> Errors.OK __ + | Types.Inr _ -> Errors.Error (Errors.msg ErrorMessages.TypeMismatch) + +(** val type_eq : Csyntax.type0 -> Csyntax.type0 -> Bool.bool **) +let type_eq t1 t2 = + match type_eq_dec t1 t2 with + | Types.Inl _ -> Bool.True + | Types.Inr _ -> Bool.False + +(** val if_type_eq : Csyntax.type0 -> Csyntax.type0 -> 'a1 -> 'a1 -> 'a1 **) +let if_type_eq t1 t2 = + match type_eq_dec t1 t2 with + | Types.Inl _ -> (fun x d -> x) + | Types.Inr _ -> (fun x d -> d) + diff --git a/extracted/typeComparison.mli b/extracted/typeComparison.mli new file mode 100644 index 0000000..6994ca6 --- /dev/null +++ b/extracted/typeComparison.mli @@ -0,0 +1,94 @@ +open Preamble + +open CostLabel + +open Coqlib + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Positive + +open Identifiers + +open Exp + +open Arithmetic + +open Vector + +open Div_and_mod + +open Util + +open FoldStuff + +open BitVector + +open Jmeq + +open Russell + +open List + +open Setoids + +open Monad + +open Option + +open Extranat + +open Bool + +open Relations + +open Nat + +open Integers + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open AST + +open Csyntax + +val sz_eq_dec : AST.intsize -> AST.intsize -> (__, __) Types.sum + +val sg_eq_dec : AST.signedness -> AST.signedness -> (__, __) Types.sum + +val fieldlist_eq_dec : + Csyntax.fieldlist -> Csyntax.fieldlist -> (__, __) Types.sum + +val typelist_eq_dec : + Csyntax.typelist -> Csyntax.typelist -> (__, __) Types.sum + +val type_eq_dec : Csyntax.type0 -> Csyntax.type0 -> (__, __) Types.sum + +val assert_type_eq : Csyntax.type0 -> Csyntax.type0 -> __ Errors.res + +val type_eq : Csyntax.type0 -> Csyntax.type0 -> Bool.bool + +val if_type_eq : Csyntax.type0 -> Csyntax.type0 -> 'a1 -> 'a1 -> 'a1 + diff --git a/extracted/types.ml b/extracted/types.ml new file mode 100644 index 0000000..6086186 --- /dev/null +++ b/extracted/types.ml @@ -0,0 +1,435 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +type void = unit (* empty inductive *) + +(** val void_rect_Type4 : void -> 'a1 **) +let rec void_rect_Type4 x_327 = + assert false (* absurd case *) + +(** val void_rect_Type5 : void -> 'a1 **) +let rec void_rect_Type5 x_328 = + assert false (* absurd case *) + +(** val void_rect_Type3 : void -> 'a1 **) +let rec void_rect_Type3 x_329 = + assert false (* absurd case *) + +(** val void_rect_Type2 : void -> 'a1 **) +let rec void_rect_Type2 x_330 = + assert false (* absurd case *) + +(** val void_rect_Type1 : void -> 'a1 **) +let rec void_rect_Type1 x_331 = + assert false (* absurd case *) + +(** val void_rect_Type0 : void -> 'a1 **) +let rec void_rect_Type0 x_332 = + assert false (* absurd case *) + +type unit0 = +| It + +(** val unit_rect_Type4 : 'a1 -> unit0 -> 'a1 **) +let rec unit_rect_Type4 h_it = function +| It -> h_it + +(** val unit_rect_Type5 : 'a1 -> unit0 -> 'a1 **) +let rec unit_rect_Type5 h_it = function +| It -> h_it + +(** val unit_rect_Type3 : 'a1 -> unit0 -> 'a1 **) +let rec unit_rect_Type3 h_it = function +| It -> h_it + +(** val unit_rect_Type2 : 'a1 -> unit0 -> 'a1 **) +let rec unit_rect_Type2 h_it = function +| It -> h_it + +(** val unit_rect_Type1 : 'a1 -> unit0 -> 'a1 **) +let rec unit_rect_Type1 h_it = function +| It -> h_it + +(** val unit_rect_Type0 : 'a1 -> unit0 -> 'a1 **) +let rec unit_rect_Type0 h_it = function +| It -> h_it + +(** val unit_inv_rect_Type4 : unit0 -> (__ -> 'a1) -> 'a1 **) +let unit_inv_rect_Type4 hterm h1 = + let hcut = unit_rect_Type4 h1 hterm in hcut __ + +(** val unit_inv_rect_Type3 : unit0 -> (__ -> 'a1) -> 'a1 **) +let unit_inv_rect_Type3 hterm h1 = + let hcut = unit_rect_Type3 h1 hterm in hcut __ + +(** val unit_inv_rect_Type2 : unit0 -> (__ -> 'a1) -> 'a1 **) +let unit_inv_rect_Type2 hterm h1 = + let hcut = unit_rect_Type2 h1 hterm in hcut __ + +(** val unit_inv_rect_Type1 : unit0 -> (__ -> 'a1) -> 'a1 **) +let unit_inv_rect_Type1 hterm h1 = + let hcut = unit_rect_Type1 h1 hterm in hcut __ + +(** val unit_inv_rect_Type0 : unit0 -> (__ -> 'a1) -> 'a1 **) +let unit_inv_rect_Type0 hterm h1 = + let hcut = unit_rect_Type0 h1 hterm in hcut __ + +(** val unit_discr : unit0 -> unit0 -> __ **) +let unit_discr x y = + Logic.eq_rect_Type2 x (let It = x in Obj.magic (fun _ dH -> dH)) y + +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +(** val sum_rect_Type4 : + ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 **) +let rec sum_rect_Type4 h_inl h_inr = function +| Inl x_371 -> h_inl x_371 +| Inr x_372 -> h_inr x_372 + +(** val sum_rect_Type5 : + ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 **) +let rec sum_rect_Type5 h_inl h_inr = function +| Inl x_376 -> h_inl x_376 +| Inr x_377 -> h_inr x_377 + +(** val sum_rect_Type3 : + ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 **) +let rec sum_rect_Type3 h_inl h_inr = function +| Inl x_381 -> h_inl x_381 +| Inr x_382 -> h_inr x_382 + +(** val sum_rect_Type2 : + ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 **) +let rec sum_rect_Type2 h_inl h_inr = function +| Inl x_386 -> h_inl x_386 +| Inr x_387 -> h_inr x_387 + +(** val sum_rect_Type1 : + ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 **) +let rec sum_rect_Type1 h_inl h_inr = function +| Inl x_391 -> h_inl x_391 +| Inr x_392 -> h_inr x_392 + +(** val sum_rect_Type0 : + ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 **) +let rec sum_rect_Type0 h_inl h_inr = function +| Inl x_396 -> h_inl x_396 +| Inr x_397 -> h_inr x_397 + +(** val sum_inv_rect_Type4 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 **) +let sum_inv_rect_Type4 hterm h1 h2 = + let hcut = sum_rect_Type4 h1 h2 hterm in hcut __ + +(** val sum_inv_rect_Type3 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 **) +let sum_inv_rect_Type3 hterm h1 h2 = + let hcut = sum_rect_Type3 h1 h2 hterm in hcut __ + +(** val sum_inv_rect_Type2 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 **) +let sum_inv_rect_Type2 hterm h1 h2 = + let hcut = sum_rect_Type2 h1 h2 hterm in hcut __ + +(** val sum_inv_rect_Type1 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 **) +let sum_inv_rect_Type1 hterm h1 h2 = + let hcut = sum_rect_Type1 h1 h2 hterm in hcut __ + +(** val sum_inv_rect_Type0 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 **) +let sum_inv_rect_Type0 hterm h1 h2 = + let hcut = sum_rect_Type0 h1 h2 hterm in hcut __ + +(** val sum_discr : ('a1, 'a2) sum -> ('a1, 'a2) sum -> __ **) +let sum_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Inl a0 -> Obj.magic (fun _ dH -> dH __) + | Inr a0 -> Obj.magic (fun _ dH -> dH __)) y + +type 'a option = +| None +| Some of 'a + +(** val option_rect_Type4 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 **) +let rec option_rect_Type4 h_None h_Some = function +| None -> h_None +| Some x_435 -> h_Some x_435 + +(** val option_rect_Type5 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 **) +let rec option_rect_Type5 h_None h_Some = function +| None -> h_None +| Some x_439 -> h_Some x_439 + +(** val option_rect_Type3 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 **) +let rec option_rect_Type3 h_None h_Some = function +| None -> h_None +| Some x_443 -> h_Some x_443 + +(** val option_rect_Type2 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 **) +let rec option_rect_Type2 h_None h_Some = function +| None -> h_None +| Some x_447 -> h_Some x_447 + +(** val option_rect_Type1 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 **) +let rec option_rect_Type1 h_None h_Some = function +| None -> h_None +| Some x_451 -> h_Some x_451 + +(** val option_rect_Type0 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 **) +let rec option_rect_Type0 h_None h_Some = function +| None -> h_None +| Some x_455 -> h_Some x_455 + +(** val option_inv_rect_Type4 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 **) +let option_inv_rect_Type4 hterm h1 h2 = + let hcut = option_rect_Type4 h1 h2 hterm in hcut __ + +(** val option_inv_rect_Type3 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 **) +let option_inv_rect_Type3 hterm h1 h2 = + let hcut = option_rect_Type3 h1 h2 hterm in hcut __ + +(** val option_inv_rect_Type2 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 **) +let option_inv_rect_Type2 hterm h1 h2 = + let hcut = option_rect_Type2 h1 h2 hterm in hcut __ + +(** val option_inv_rect_Type1 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 **) +let option_inv_rect_Type1 hterm h1 h2 = + let hcut = option_rect_Type1 h1 h2 hterm in hcut __ + +(** val option_inv_rect_Type0 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 **) +let option_inv_rect_Type0 hterm h1 h2 = + let hcut = option_rect_Type0 h1 h2 hterm in hcut __ + +(** val option_discr : 'a1 option -> 'a1 option -> __ **) +let option_discr x y = + Logic.eq_rect_Type2 x + (match x with + | None -> Obj.magic (fun _ dH -> dH) + | Some a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val option_map : ('a1 -> 'a2) -> 'a1 option -> 'a2 option **) +let option_map f = function +| None -> None +| Some a -> Some (f a) + +(** val option_map_def : ('a1 -> 'a2) -> 'a2 -> 'a1 option -> 'a2 **) +let option_map_def f d = function +| None -> d +| Some a -> f a + +(** val refute_none_by_refl : + ('a1 -> 'a2) -> 'a1 option -> ('a1 -> __ -> 'a3) -> 'a3 **) +let refute_none_by_refl p clearme x = + (match clearme with + | None -> (fun _ -> assert false (* absurd case *)) + | Some a -> (fun _ p0 -> p0 a __)) __ x + +type ('a, 'f) dPair = { dpi1 : 'a; dpi2 : 'f } + +(** val dPair_rect_Type4 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 **) +let rec dPair_rect_Type4 h_mk_DPair x_484 = + let { dpi1 = dpi3; dpi2 = dpi4 } = x_484 in h_mk_DPair dpi3 dpi4 + +(** val dPair_rect_Type5 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 **) +let rec dPair_rect_Type5 h_mk_DPair x_486 = + let { dpi1 = dpi3; dpi2 = dpi4 } = x_486 in h_mk_DPair dpi3 dpi4 + +(** val dPair_rect_Type3 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 **) +let rec dPair_rect_Type3 h_mk_DPair x_488 = + let { dpi1 = dpi3; dpi2 = dpi4 } = x_488 in h_mk_DPair dpi3 dpi4 + +(** val dPair_rect_Type2 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 **) +let rec dPair_rect_Type2 h_mk_DPair x_490 = + let { dpi1 = dpi3; dpi2 = dpi4 } = x_490 in h_mk_DPair dpi3 dpi4 + +(** val dPair_rect_Type1 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 **) +let rec dPair_rect_Type1 h_mk_DPair x_492 = + let { dpi1 = dpi3; dpi2 = dpi4 } = x_492 in h_mk_DPair dpi3 dpi4 + +(** val dPair_rect_Type0 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 **) +let rec dPair_rect_Type0 h_mk_DPair x_494 = + let { dpi1 = dpi3; dpi2 = dpi4 } = x_494 in h_mk_DPair dpi3 dpi4 + +(** val dpi1 : ('a1, 'a2) dPair -> 'a1 **) +let rec dpi1 xxx = + xxx.dpi1 + +(** val dpi2 : ('a1, 'a2) dPair -> 'a2 **) +let rec dpi2 xxx = + xxx.dpi2 + +(** val dPair_inv_rect_Type4 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let dPair_inv_rect_Type4 hterm h1 = + let hcut = dPair_rect_Type4 h1 hterm in hcut __ + +(** val dPair_inv_rect_Type3 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let dPair_inv_rect_Type3 hterm h1 = + let hcut = dPair_rect_Type3 h1 hterm in hcut __ + +(** val dPair_inv_rect_Type2 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let dPair_inv_rect_Type2 hterm h1 = + let hcut = dPair_rect_Type2 h1 hterm in hcut __ + +(** val dPair_inv_rect_Type1 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let dPair_inv_rect_Type1 hterm h1 = + let hcut = dPair_rect_Type1 h1 hterm in hcut __ + +(** val dPair_inv_rect_Type0 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let dPair_inv_rect_Type0 hterm h1 = + let hcut = dPair_rect_Type0 h1 hterm in hcut __ + +(** val dPair_discr : ('a1, 'a2) dPair -> ('a1, 'a2) dPair -> __ **) +let dPair_discr x y = + Logic.eq_rect_Type2 x + (let { dpi1 = a0; dpi2 = a10 } = x in Obj.magic (fun _ dH -> dH __ __)) y + +type 'a sig0 = + 'a + (* singleton inductive, whose constructor was mk_Sig *) + +(** val sig_rect_Type4 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 **) +let rec sig_rect_Type4 h_mk_Sig x_510 = + let pi1 = x_510 in h_mk_Sig pi1 __ + +(** val sig_rect_Type5 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 **) +let rec sig_rect_Type5 h_mk_Sig x_512 = + let pi1 = x_512 in h_mk_Sig pi1 __ + +(** val sig_rect_Type3 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 **) +let rec sig_rect_Type3 h_mk_Sig x_514 = + let pi1 = x_514 in h_mk_Sig pi1 __ + +(** val sig_rect_Type2 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 **) +let rec sig_rect_Type2 h_mk_Sig x_516 = + let pi1 = x_516 in h_mk_Sig pi1 __ + +(** val sig_rect_Type1 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 **) +let rec sig_rect_Type1 h_mk_Sig x_518 = + let pi1 = x_518 in h_mk_Sig pi1 __ + +(** val sig_rect_Type0 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 **) +let rec sig_rect_Type0 h_mk_Sig x_520 = + let pi1 = x_520 in h_mk_Sig pi1 __ + +(** val pi1 : 'a1 sig0 -> 'a1 **) +let rec pi1 xxx = + let yyy = xxx in yyy + +(** val sig_inv_rect_Type4 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 **) +let sig_inv_rect_Type4 hterm h1 = + let hcut = sig_rect_Type4 h1 hterm in hcut __ + +(** val sig_inv_rect_Type3 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 **) +let sig_inv_rect_Type3 hterm h1 = + let hcut = sig_rect_Type3 h1 hterm in hcut __ + +(** val sig_inv_rect_Type2 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 **) +let sig_inv_rect_Type2 hterm h1 = + let hcut = sig_rect_Type2 h1 hterm in hcut __ + +(** val sig_inv_rect_Type1 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 **) +let sig_inv_rect_Type1 hterm h1 = + let hcut = sig_rect_Type1 h1 hterm in hcut __ + +(** val sig_inv_rect_Type0 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 **) +let sig_inv_rect_Type0 hterm h1 = + let hcut = sig_rect_Type0 h1 hterm in hcut __ + +(** val sig_discr : 'a1 sig0 -> 'a1 sig0 -> __ **) +let sig_discr x y = + Logic.eq_rect_Type2 x (let a0 = x in Obj.magic (fun _ dH -> dH __ __)) y + +type ('a, 'b) prod = { fst : 'a; snd : 'b } + +(** val prod_rect_Type4 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 **) +let rec prod_rect_Type4 h_mk_Prod x_536 = + let { fst = fst0; snd = snd0 } = x_536 in h_mk_Prod fst0 snd0 + +(** val prod_rect_Type5 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 **) +let rec prod_rect_Type5 h_mk_Prod x_538 = + let { fst = fst0; snd = snd0 } = x_538 in h_mk_Prod fst0 snd0 + +(** val prod_rect_Type3 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 **) +let rec prod_rect_Type3 h_mk_Prod x_540 = + let { fst = fst0; snd = snd0 } = x_540 in h_mk_Prod fst0 snd0 + +(** val prod_rect_Type2 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 **) +let rec prod_rect_Type2 h_mk_Prod x_542 = + let { fst = fst0; snd = snd0 } = x_542 in h_mk_Prod fst0 snd0 + +(** val prod_rect_Type1 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 **) +let rec prod_rect_Type1 h_mk_Prod x_544 = + let { fst = fst0; snd = snd0 } = x_544 in h_mk_Prod fst0 snd0 + +(** val prod_rect_Type0 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 **) +let rec prod_rect_Type0 h_mk_Prod x_546 = + let { fst = fst0; snd = snd0 } = x_546 in h_mk_Prod fst0 snd0 + +(** val fst : ('a1, 'a2) prod -> 'a1 **) +let rec fst xxx = + xxx.fst + +(** val snd : ('a1, 'a2) prod -> 'a2 **) +let rec snd xxx = + xxx.snd + +(** val prod_inv_rect_Type4 : + ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let prod_inv_rect_Type4 hterm h1 = + let hcut = prod_rect_Type4 h1 hterm in hcut __ + +(** val prod_inv_rect_Type3 : + ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let prod_inv_rect_Type3 hterm h1 = + let hcut = prod_rect_Type3 h1 hterm in hcut __ + +(** val prod_inv_rect_Type2 : + ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let prod_inv_rect_Type2 hterm h1 = + let hcut = prod_rect_Type2 h1 hterm in hcut __ + +(** val prod_inv_rect_Type1 : + ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let prod_inv_rect_Type1 hterm h1 = + let hcut = prod_rect_Type1 h1 hterm in hcut __ + +(** val prod_inv_rect_Type0 : + ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 **) +let prod_inv_rect_Type0 hterm h1 = + let hcut = prod_rect_Type0 h1 hterm in hcut __ + +(** val prod_discr : ('a1, 'a2) prod -> ('a1, 'a2) prod -> __ **) +let prod_discr x y = + Logic.eq_rect_Type2 x + (let { fst = a0; snd = a10 } = x in Obj.magic (fun _ dH -> dH __ __)) y + +(** val coerc_pair_sigma : ('a1, 'a2) prod -> ('a1, 'a2 sig0) prod **) +let coerc_pair_sigma clearme = + (let { fst = a; snd = b } = clearme in (fun _ -> { fst = a; snd = b })) __ + +(** val dpi1__o__coerc_pair_sigma : + (('a1, 'a2) prod, 'a3) dPair -> ('a1, 'a2 sig0) prod **) +let dpi1__o__coerc_pair_sigma x4 = + coerc_pair_sigma x4.dpi1 + diff --git a/extracted/types.mli b/extracted/types.mli new file mode 100644 index 0000000..3013c91 --- /dev/null +++ b/extracted/types.mli @@ -0,0 +1,224 @@ +open Preamble + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +type void = unit (* empty inductive *) + +val void_rect_Type4 : void -> 'a1 + +val void_rect_Type5 : void -> 'a1 + +val void_rect_Type3 : void -> 'a1 + +val void_rect_Type2 : void -> 'a1 + +val void_rect_Type1 : void -> 'a1 + +val void_rect_Type0 : void -> 'a1 + +type unit0 = +| It + +val unit_rect_Type4 : 'a1 -> unit0 -> 'a1 + +val unit_rect_Type5 : 'a1 -> unit0 -> 'a1 + +val unit_rect_Type3 : 'a1 -> unit0 -> 'a1 + +val unit_rect_Type2 : 'a1 -> unit0 -> 'a1 + +val unit_rect_Type1 : 'a1 -> unit0 -> 'a1 + +val unit_rect_Type0 : 'a1 -> unit0 -> 'a1 + +val unit_inv_rect_Type4 : unit0 -> (__ -> 'a1) -> 'a1 + +val unit_inv_rect_Type3 : unit0 -> (__ -> 'a1) -> 'a1 + +val unit_inv_rect_Type2 : unit0 -> (__ -> 'a1) -> 'a1 + +val unit_inv_rect_Type1 : unit0 -> (__ -> 'a1) -> 'a1 + +val unit_inv_rect_Type0 : unit0 -> (__ -> 'a1) -> 'a1 + +val unit_discr : unit0 -> unit0 -> __ + +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +val sum_rect_Type4 : ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 + +val sum_rect_Type5 : ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 + +val sum_rect_Type3 : ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 + +val sum_rect_Type2 : ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 + +val sum_rect_Type1 : ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 + +val sum_rect_Type0 : ('a1 -> 'a3) -> ('a2 -> 'a3) -> ('a1, 'a2) sum -> 'a3 + +val sum_inv_rect_Type4 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 + +val sum_inv_rect_Type3 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 + +val sum_inv_rect_Type2 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 + +val sum_inv_rect_Type1 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 + +val sum_inv_rect_Type0 : + ('a1, 'a2) sum -> ('a1 -> __ -> 'a3) -> ('a2 -> __ -> 'a3) -> 'a3 + +val sum_discr : ('a1, 'a2) sum -> ('a1, 'a2) sum -> __ + +type 'a option = +| None +| Some of 'a + +val option_rect_Type4 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 + +val option_rect_Type5 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 + +val option_rect_Type3 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 + +val option_rect_Type2 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 + +val option_rect_Type1 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 + +val option_rect_Type0 : 'a2 -> ('a1 -> 'a2) -> 'a1 option -> 'a2 + +val option_inv_rect_Type4 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 + +val option_inv_rect_Type3 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 + +val option_inv_rect_Type2 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 + +val option_inv_rect_Type1 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 + +val option_inv_rect_Type0 : + 'a1 option -> (__ -> 'a2) -> ('a1 -> __ -> 'a2) -> 'a2 + +val option_discr : 'a1 option -> 'a1 option -> __ + +val option_map : ('a1 -> 'a2) -> 'a1 option -> 'a2 option + +val option_map_def : ('a1 -> 'a2) -> 'a2 -> 'a1 option -> 'a2 + +val refute_none_by_refl : + ('a1 -> 'a2) -> 'a1 option -> ('a1 -> __ -> 'a3) -> 'a3 + +type ('a, 'f) dPair = { dpi1 : 'a; dpi2 : 'f } + +val dPair_rect_Type4 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 + +val dPair_rect_Type5 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 + +val dPair_rect_Type3 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 + +val dPair_rect_Type2 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 + +val dPair_rect_Type1 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 + +val dPair_rect_Type0 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) dPair -> 'a3 + +val dpi1 : ('a1, 'a2) dPair -> 'a1 + +val dpi2 : ('a1, 'a2) dPair -> 'a2 + +val dPair_inv_rect_Type4 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val dPair_inv_rect_Type3 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val dPair_inv_rect_Type2 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val dPair_inv_rect_Type1 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val dPair_inv_rect_Type0 : + ('a1, 'a2) dPair -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val dPair_discr : ('a1, 'a2) dPair -> ('a1, 'a2) dPair -> __ + +type 'a sig0 = + 'a + (* singleton inductive, whose constructor was mk_Sig *) + +val sig_rect_Type4 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 + +val sig_rect_Type5 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 + +val sig_rect_Type3 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 + +val sig_rect_Type2 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 + +val sig_rect_Type1 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 + +val sig_rect_Type0 : ('a1 -> __ -> 'a2) -> 'a1 sig0 -> 'a2 + +val pi1 : 'a1 sig0 -> 'a1 + +val sig_inv_rect_Type4 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 + +val sig_inv_rect_Type3 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 + +val sig_inv_rect_Type2 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 + +val sig_inv_rect_Type1 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 + +val sig_inv_rect_Type0 : 'a1 sig0 -> ('a1 -> __ -> __ -> 'a2) -> 'a2 + +val sig_discr : 'a1 sig0 -> 'a1 sig0 -> __ + +type ('a, 'b) prod = { fst : 'a; snd : 'b } + +val prod_rect_Type4 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 + +val prod_rect_Type5 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 + +val prod_rect_Type3 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 + +val prod_rect_Type2 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 + +val prod_rect_Type1 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 + +val prod_rect_Type0 : ('a1 -> 'a2 -> 'a3) -> ('a1, 'a2) prod -> 'a3 + +val fst : ('a1, 'a2) prod -> 'a1 + +val snd : ('a1, 'a2) prod -> 'a2 + +val prod_inv_rect_Type4 : ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val prod_inv_rect_Type3 : ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val prod_inv_rect_Type2 : ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val prod_inv_rect_Type1 : ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val prod_inv_rect_Type0 : ('a1, 'a2) prod -> ('a1 -> 'a2 -> __ -> 'a3) -> 'a3 + +val prod_discr : ('a1, 'a2) prod -> ('a1, 'a2) prod -> __ + +val coerc_pair_sigma : ('a1, 'a2) prod -> ('a1, 'a2 sig0) prod + +val dpi1__o__coerc_pair_sigma : + (('a1, 'a2) prod, 'a3) dPair -> ('a1, 'a2 sig0) prod + diff --git a/extracted/untrusted/Fix.ml b/extracted/untrusted/Fix.ml new file mode 100644 index 0000000..d8544b4 --- /dev/null +++ b/extracted/untrusted/Fix.ml @@ -0,0 +1,529 @@ +(**************************************************************************) +(* *) +(* Fix *) +(* *) +(* Author: François Pottier, INRIA Paris-Rocquencourt *) +(* Version: 20091201 *) +(* *) +(* The copyright to this code is held by Institut National de Recherche *) +(* en Informatique et en Automatique (INRIA). All rights reserved. This *) +(* file is distributed under the license CeCILL-C (see file LICENSE). *) +(* *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) + +(* Maps. *) + +(* We require imperative maps, that is, maps that can be updated in place. + An implementation of persistent maps, such as the one offered by ocaml's + standard library, can easily be turned into an implementation of imperative + maps, so this is a weak requirement. *) + +module type IMPERATIVE_MAPS = sig + type key + type 'data t + val create: unit -> 'data t + val clear: 'data t -> unit + val add: key -> 'data -> 'data t -> unit + val find: key -> 'data t -> 'data + val iter: (key -> 'data -> unit) -> 'data t -> unit +end + +(* -------------------------------------------------------------------------- *) + +(* Properties. *) + +(* Properties must form a partial order, equipped with a least element, and + must satisfy the ascending chain condition: every monotone sequence + eventually stabilizes. *) + +(* [is_maximal] determines whether a property [p] is maximal with respect to + the partial order. Only a conservative check is required: in any event, it + is permitted for [is_maximal p] to return [false]. If [is_maximal p] + returns [true], then [p] must have no upper bound other than itself. In + particular, if properties form a lattice, then [p] must be the top + element. This feature, not described in the paper, enables a couple of + minor optimizations. *) + +module type PROPERTY = sig + type property + val bottom: property + val equal: property -> property -> bool + val is_maximal: property -> bool +end + +(* -------------------------------------------------------------------------- *) + +(* The dynamic dependency graph. *) + +(* An edge from [node1] to [node2] means that [node1] depends on [node2], or + (equivalently) that [node1] observes [node2]. Then, an update of the + current property at [node2] causes a signal to be sent to [node1]. A node + can observe itself. *) + +(* This module could be placed in a separate file, but is included here in + order to make [Fix] self-contained. *) + +module Graph : sig + + (* This module provides a data structure for maintaining and modifying + a directed graph. Each node is allowed to carry a piece of client + data. There are functions for creating a new node, looking up a + node's data, looking up a node's predecessors, and setting or + clearing a node's successors (all at once). *) + type 'data node + + (* [create data] creates a new node, with no incident edges, with + client information [data]. Time complexity: constant. *) + val create: 'data -> 'data node + + (* [data node] returns the client information associated with + the node [node]. Time complexity: constant. *) + val data: 'data node -> 'data + + (* [predecessors node] returns a list of [node]'s predecessors. + Amortized time complexity: linear in the length of the output + list. *) + val predecessors: 'data node -> 'data node list + + (* [set_successors src dsts] creates an edge from the node [src] to + each of the nodes in the list [dsts]. Duplicate elements in the + list [dsts] are removed, so that no duplicate edges are created. It + is assumed that [src] initially has no successors. Time complexity: + linear in the length of the input list. *) + val set_successors: 'data node -> 'data node list -> unit + + (* [clear_successors node] removes all of [node]'s outgoing edges. + Time complexity: linear in the number of edges that are removed. *) + val clear_successors: 'data node -> unit + + (* That's it. *) +end += struct + + (* Using doubly-linked adjacency lists, one could implement [predecessors] + in worst-case linear time with respect to the length of the output list, + [set_successors] in worst-case linear time with respect to the length of + the input list, and [clear_successors] in worst-case linear time with + respect to the number of edges that are removed. We use a simpler + implementation, based on singly-linked adjacency lists, with deferred + removal of edges. It achieves the same complexity bounds, except + [predecessors] only offers an amortized complexity bound. This is good + enough for our purposes, and, in practice, is more efficient by a + constant factor. This simplification was suggested by Arthur + Charguéraud. *) + + type 'data node = { + + (* The client information associated with this node. *) + + data: 'data; + + (* This node's incoming and outgoing edges. *) + + mutable outgoing: 'data edge list; + mutable incoming: 'data edge list; + + (* A transient mark, always set to [false], except when checking + against duplicate elements in a successor list. *) + + mutable marked: bool; + + } + + and 'data edge = { + + (* This edge's nodes. Edges are symmetric: source and destination + are not distinguished. Thus, an edge appears both in the outgoing + edge list of its source node and in the incoming edge list of its + destination node. This allows edges to be easily marked as + destroyed. *) + + node1: 'data node; + node2: 'data node; + + (* Edges that are destroyed are marked as such, but are not + immediately removed from the adjacency lists. *) + + mutable destroyed: bool; + + } + + let create (data : 'data) : 'data node = { + data = data; + outgoing = []; + incoming = []; + marked = false; + } + + let data (node : 'data node) : 'data = + node.data + + (* [follow src edge] returns the node that is connected to [src] + by [edge]. Time complexity: constant. *) + + let follow src edge = + if edge.node1 == src then + edge.node2 + else begin + assert (edge.node2 == src); + edge.node1 + end + + (* The [predecessors] function removes edges that have been marked + destroyed. The cost of removing these has already been paid for, + so the amortized time complexity of [predecessors] is linear in + the length of the output list. *) + + let predecessors (node : 'data node) : 'data node list = + let predecessors = OcamlList.filter (fun edge -> not edge.destroyed) node.incoming in + node.incoming <- predecessors; + OcamlList.map (follow node) predecessors + + (* [link src dst] creates a new edge from [src] to [dst], together + with its reverse edge. Time complexity: constant. *) + + let link (src : 'data node) (dst : 'data node) : unit = + let edge = { + node1 = src; + node2 = dst; + destroyed = false; + } in + src.outgoing <- edge :: src.outgoing; + dst.incoming <- edge :: dst.incoming + + let set_successors (src : 'data node) (dsts : 'data node list) : unit = + assert (src.outgoing = []); + let rec loop = function + | [] -> + () + | dst :: dsts -> + if dst.marked then + loop dsts (* skip duplicate elements *) + else begin + dst.marked <- true; + link src dst; + loop dsts; + dst.marked <- false + end + in + loop dsts + + let clear_successors (node : 'data node) : unit = + OcamlList.iter (fun edge -> + assert (not edge.destroyed); + edge.destroyed <- true; + ) node.outgoing; + node.outgoing <- [] + +end + +(* -------------------------------------------------------------------------- *) + +(* The code is parametric in an implementation of maps over variables and in + an implementation of properties. *) + +module Make + (M : IMPERATIVE_MAPS) + (P : PROPERTY) += struct + +type variable = + M.key + +type property = + P.property + +type valuation = + variable -> property + +type rhs = + valuation -> property + +type equations = + variable -> rhs + +(* -------------------------------------------------------------------------- *) + +(* Data. *) + +(* Each node in the dependency graph carries information about a fixed + variable [v]. *) + +type node = + data Graph.node + +and data = { + + (* This is the result of the application of [rhs] to the variable [v]. It + must be stored in order to guarantee that this application is performed + at most once. *) + rhs: rhs; + + (* This is the current property at [v]. It evolves monotonically with + time. *) + mutable property: property; + + (* That's it! *) +} + +(* [property node] returns the current property at [node]. *) + +let property node = + (Graph.data node).property + +(* -------------------------------------------------------------------------- *) + +(* Many definitions must be made within the body of the function [lfp]. + For greater syntactic convenience, we place them in a local module. *) + +let lfp (eqs : equations) : valuation = + let module LFP = struct + +(* -------------------------------------------------------------------------- *) + +(* The workset. *) + +(* When the algorithm is inactive, the workset is empty. *) + +(* Our workset is based on a Queue, but it could just as well be based on a + Stack. A textual replacement is possible. It could also be based on a + priority queue, provided a sensible way of assigning priorities could + be found. *) + +module Workset : sig + + (* [insert node] inserts [node] into the workset. [node] must have no + successors. *) + val insert: node -> unit + + (* [repeat f] repeatedly applies [f] to a node extracted out of the + workset, until the workset becomes empty. [f] is allowed to use + [insert]. *) + val repeat: (node -> unit) -> unit + + (* That's it! *) +end += struct + + (* Initialize the workset. *) + + let workset = + Queue.create() + + let insert node = + Queue.push node workset + + let repeat f = + while not (Queue.is_empty workset) do + f (Queue.pop workset) + done + +end + +(* -------------------------------------------------------------------------- *) + +(* Signals. *) + +(* A node in the workset has no successors. (It can have predecessors.) In + other words, a predecessor (an observer) of some node is never in the + workset. Furthermore, a node never appears twice in the workset. *) + +(* When a variable broadcasts a signal, all of its predecessors (observers) + receive the signal. Any variable that receives the signal loses all of its + successors (that is, it ceases to observe anything) and is inserted into + the workset. This preserves the above invariant. *) + +let signal subject = + OcamlList.iter (fun observer -> + Graph.clear_successors observer; + Workset.insert observer + ) (Graph.predecessors subject) + (* At this point, [subject] has no predecessors. This plays no role in + the correctness proof, though. *) + +(* -------------------------------------------------------------------------- *) + +(* Tables. *) + +(* The permanent table maps variables that have reached a fixed point + to properties. It persists forever. *) + +let permanent : property M.t = + M.create() + +(* The transient table maps variables that have not yet reached a + fixed point to nodes. (A node contains not only a property, but + also a memoized right-hand side, and carries edges.) At the + beginning of a run, it is empty. It fills up during a run. At the + end of a run, it is copied into the permanent table and cleared. *) + +let transient : node M.t = + M.create() + +(* [freeze()] copies the transient table into the permanent table, and + empties the transient table. This allows all nodes to be reclaimed + by the garbage collector. *) + +let freeze () = + M.iter (fun v node -> + M.add v (property node) permanent + ) transient; + M.clear transient + +(* -------------------------------------------------------------------------- *) + +(* Workset processing. *) + + +(* [solve node] re-evaluates the right-hand side at [node]. If this leads to + a change, then the current property is updated, and [node] emits a signal + towards its observers. *) + +(* When [solve node] is invoked, [node] has no subjects. Indeed, when [solve] + is invoked by [node_for], [node] is newly created; when [solve] is invoked by + [Workset.repeat], [node] has just been extracted out of the workset, and a + node in the workset has no subjects. *) + +(* [node] must not be in the workset. *) + +(* In short, when [solve node] is invoked, [node] is neither awake nor asleep. + When [solve node] finishes, [node] is either awake or asleep again. (Chances + are, it is asleep, unless it is its own observer; then, it is awakened by the + final call to [signal node].) *) + +let rec solve (node : node) : unit = + + (* Retrieve the data record carried by this node. *) + let data = Graph.data node in + + (* Prepare to compute an updated value at this node. This is done by + invoking the client's right-hand side function. *) + + (* The flag [alive] is used to prevent the client from invoking [request] + after this interaction phase is over. In theory, this dynamic check seems + required in order to argue that [request] behaves like a pure function. + In practice, this check is not very useful: only a bizarre client would + store a [request] function and invoke it after it has become stale. *) + let alive = ref true + and subjects = ref [] in + + (* We supply the client with [request], a function that provides access to + the current valuation, and dynamically records dependencies. This yields + a set of dependencies that is correct by construction. *) + let request (v : variable) : property = + assert !alive; + try + M.find v permanent + with Not_found -> + let subject = node_for v in + let p = property subject in + if not (P.is_maximal p) then + subjects := subject :: !subjects; + p + in + + (* Give control to the client. *) + let new_property = data.rhs request in + + (* From now on, prevent any invocation of this instance of [request] + the client. *) + alive := false; + + (* At this point, [node] has no subjects, as noted above. Thus, the + precondition of [set_successors] is met. We can install [data.subjects] + as the new set of subjects for this node. *) + + (* If we have gathered no subjects in the list [data.subjects], then + this node must have stabilized. If [new_property] is maximal, + then this node must have stabilized. *) + + (* If this node has stabilized, then it need not observe any more, so the + call to [set_successors] is skipped. In practice, this seems to be a + minor optimization. In the particular case where every node stabilizes at + the very first call to [rhs], this means that no edges are ever + built. This particular case is unlikely, as it means that we are just + doing memoization, not a true fixed point computation. *) + + (* One could go further and note that, if this node has stabilized, then it + could immediately be taken out of the transient table and copied into the + permanent table. This would have the beneficial effect of allowing the + detection of further nodes that have stabilized. Furthermore, it would + enforce the property that no node in the transient table has a maximal + value, hence the call to [is_maximal] above would become useless. *) + + if not (!subjects = [] || P.is_maximal new_property) then + Graph.set_successors node !subjects; + + (* If the updated value differs from the previous value, record + the updated value and send a signal to all observers of [node]. *) + if not (P.equal data.property new_property) then begin + data.property <- new_property; + signal node + end + (* Note that equality of the two values does not imply that this node has + stabilized forever. *) + +(* -------------------------------------------------------------------------- *) + +(* [node_for v] returns the graph node associated with the variable [v]. It is + assumed that [v] does not appear in the permanent table. If [v] appears in + the transient table, the associated node is returned. Otherwise, [v] is a + newly discovered variable: a new node is created on the fly, and the + transient table is grown. The new node can either be inserted into the + workset (it is then awake) or handled immediately via a recursive call to + [solve] (it is then asleep, unless it observes itself). *) + +(* The recursive call to [solve node] can be replaced, if desired, by a call + to [Workset.insert node]. Using a recursive call to [solve] permits eager + top-down discovery of new nodes. This can save a constant factor, because + it allows new nodes to move directly from [bottom] to a good first + approximation, without sending any signals, since [node] has no observers + when [solve node] is invoked. In fact, if the dependency graph is acyclic, + the algorithm discovers nodes top-down, performs computation on the way + back up, and runs without ever inserting a node into the workset! + Unfortunately, this causes the stack to grow as deep as the longest path in + the dependency graph, which can blow up the stack. *) + +and node_for (v : variable) : node = + try + M.find v transient + with Not_found -> + let node = Graph.create { rhs = eqs v; property = P.bottom } in + (* Adding this node to the transient table prior to calling [solve] + recursively is mandatory, otherwise [solve] might loop, creating + an infinite number of nodes for the same variable. *) + M.add v node transient; + solve node; (* or: Workset.insert node *) + node + +(* -------------------------------------------------------------------------- *) + +(* Invocations of [get] trigger the fixed point computation. *) + +(* The flag [inactive] prevents reentrant calls by the client. *) + +let inactive = + ref true + +let get (v : variable) : property = + try + M.find v permanent + with Not_found -> + assert !inactive; + inactive := false; + let node = node_for v in + Workset.repeat solve; + freeze(); + inactive := true; + property node + +(* -------------------------------------------------------------------------- *) + +(* Close the local module [LFP]. *) + +end +in LFP.get + +end diff --git a/extracted/untrusted/Fix.mli b/extracted/untrusted/Fix.mli new file mode 100644 index 0000000..4f7fde0 --- /dev/null +++ b/extracted/untrusted/Fix.mli @@ -0,0 +1,103 @@ + +(** This module provides a generic algorithm to compute the least + solution of a system of monotonic equations. *) + +(**************************************************************************) +(* *) +(* Fix *) +(* *) +(* Author: François Pottier, INRIA Paris-Rocquencourt *) +(* Version: 20091201 *) +(* *) +(* The copyright to this code is held by Institut National de Recherche *) +(* en Informatique et en Automatique (INRIA). All rights reserved. This *) +(* file is distributed under the license CeCILL-C (see file LICENSE). *) +(* *) +(**************************************************************************) + +(* This code is described in the paper ``Lazy Least Fixed Points in ML''. *) + +(* -------------------------------------------------------------------------- *) + +(* Maps. *) + +(* We require imperative maps, that is, maps that can be updated in place. + An implementation of persistent maps, such as the one offered by ocaml's + standard library, can easily be turned into an implementation of imperative + maps, so this is a weak requirement. *) + +module type IMPERATIVE_MAPS = sig + type key + type 'data t + val create: unit -> 'data t + val clear: 'data t -> unit + val add: key -> 'data -> 'data t -> unit + val find: key -> 'data t -> 'data + val iter: (key -> 'data -> unit) -> 'data t -> unit +end + +(* -------------------------------------------------------------------------- *) + +(* Properties. *) + +(* Properties must form a partial order, equipped with a least element, and + must satisfy the ascending chain condition: every monotone sequence + eventually stabilizes. *) + +(* [is_maximal] determines whether a property [p] is maximal with respect to + the partial order. Only a conservative check is required: in any event, it + is permitted for [is_maximal p] to return [false]. If [is_maximal p] + returns [true], then [p] must have no upper bound other than itself. In + particular, if properties form a lattice, then [p] must be the top + element. This feature, not described in the paper, enables a couple of + minor optimizations. *) + +module type PROPERTY = sig + type property + val bottom: property + val equal: property -> property -> bool + val is_maximal: property -> bool +end + +(* -------------------------------------------------------------------------- *) + +(* The code is parametric in an implementation of maps over variables and in + an implementation of properties. *) + +module Make + (M : IMPERATIVE_MAPS) + (P : PROPERTY) + : sig + type variable = M.key + type property = P.property + + (* A valuation is a mapping of variables to properties. *) + type valuation = variable -> property + + (* A right-hand side, when supplied with a valuation that gives + meaning to its free variables, evaluates to a property. More + precisely, a right-hand side is a monotone function of + valuations to properties. *) + type rhs = valuation -> property + + (* A system of equations is a mapping of variables to right-hand + sides. *) + type equations = variable -> rhs + + (* [lfp eqs] produces the least solution of the system of monotone + equations [eqs]. *) + + (* It is guaranteed that, for each variable [v], the application [eqs v] is + performed at most once (whereas the right-hand side produced by this + application is, in general, evaluated multiple times). This guarantee can + be used to perform costly pre-computation, or memory allocation, when [eqs] + is applied to its first argument. *) + + (* When [lfp] is applied to a system of equations [eqs], it performs no + actual computation. It produces a valuation, [get], which represents + the least solution of the system of equations. The actual fixed point + computation takes place, on demand, when [get] is applied. *) + val lfp: equations -> valuation + end + +(** val compute_fixpoint : Fixpoints.fixpoint_computer **) diff --git a/extracted/untrusted/build.ml b/extracted/untrusted/build.ml new file mode 100644 index 0000000..89e561c --- /dev/null +++ b/extracted/untrusted/build.ml @@ -0,0 +1,137 @@ +(* Pasted from Pottier's PP compiler *) + +open ERTL +open Untrusted_interference + +let build globals int_fun uses liveafter = + + (* Create an interference graph whose vertices are the procedure's + pseudo-registers. This graph initially has no edges. *) + + let f_locals = + Identifiers.foldi PreIdentifiers.RegisterTag + (fun id _ map -> Pset.add id map + ) uses Pset.empty in + + let graph = create f_locals in + + (* Every pseudo register interferes with special forbidden registers. *) + + let graph = mkiph graph f_locals + (Untrusted_interference.hwregisterset_of_list I8051.registersForbidden) in + + (* Iterate over all statements in the control flow graph and populate the + interference graph with interference and preference edges. *) + + let graph = + Identifiers.foldi PreIdentifiers.LabelTag (fun label stmt graph -> + let live = liveafter label in + if Liveness.eliminable globals live stmt = Bool.True then + + (* This statement is eliminable and should be ignored. Eliminable + statements have not been eliminated yet, because we are still + in between ERTL and LTL. They *will* be eliminated soon, though, + so there is no reason to take them into account while building + the interference graph. *) + + graph + + else + + (* Create interference edges. The general rule is, every + pseudo-register or hardware register that is defined (written) by + a statement interferes with every pseudo-register or hardware + register (other than itself) that is live immediately after the + statement executes. + + An exception to the general rule can be made for move + statements. In a move statement, we do not need the source + and destination pseudo-registers to be assigned distinct hardware + registers, since they contain the same value -- in fact, we would + like them to be assigned the same hardware register. So, for a + move statement, we let the register that is defined (written) + interfere with every pseudo-register, other than itself *and + other than the source pseudo-register*, that is live immediately + after the statement executes. This optimization is explained in + Chapter 10 of Appel's book (p. 221). + + This special case is only a hack that works in many cases. There + are cases where it doesn't suffice. For instance, if two + successive move statements have the same source [r0], then + their destinations [r1] and [r2] *will* be considered as + interfering, even though it would in fact be correct and + desirable to map both of them to the same hardware register. A + more general solution would be to perform a static analysis that + determines, for every program point, which pseudo-registers + definitely hold the same value, and to exploit this information + to build fewer interference edges. *) + + let defined = Liveness.defined globals stmt in + let exceptions = + match stmt with + | Joint.Sequential (Joint.Step_seq (Joint.MOVE arg),_) -> + (match Obj.magic arg with + {Types.snd = Joint.Reg (ERTL.PSD sourcer)} -> + Liveness.rl_psingleton sourcer + | {Types.snd = Joint.Reg (ERTL.HDW sourcehwr)} -> + Liveness.rl_hsingleton sourcehwr + | _ -> Liveness.rl_bottom) + | _ -> + Liveness.rl_bottom + in + let graph = + mki graph (Obj.magic (Liveness.rl_diff live exceptions)) + (Obj.magic defined) + in + +(* + (* Two registers written at the same time are interfering (they + obviously should not be associated the same address). + Only happens with St_addr. *) + + let graph = + match stmt with + | St_addr (r1, r2, _, _) -> + mki graph (Liveness.L.psingleton r1) (Liveness.L.psingleton r2) + | _ -> + graph + in +*) + + (* Create preference edges between pseudo-registers. Two registers + should preferably be assigned the same color when they are + related by a move statement, so that the move statement can + be eliminated. *) + + let graph = + match stmt with + | Joint.Sequential (Joint.Step_seq (Joint.MOVE arg),_) -> + (match Obj.magic arg with + {Types.fst = ERTL.PSD r1 ; snd = Joint.Reg (ERTL.PSD r2)} -> + mkppp graph r1 r2 + | {Types.fst = ERTL.PSD r1 ; snd = Joint.Reg (ERTL.HDW r2)} + | {Types.fst = ERTL.HDW r2 ; snd = Joint.Reg (ERTL.PSD r1)} -> + mkpph graph r1 r2 + | _ -> graph) + | _ -> + graph + in + (* + + (* Add interference edges between the hardware register [$zero] + and every pseudo-register that the statement renders + nonzeroable. See [Zero] for an explanation. *) + + let graph = + mkiph graph (Zero.nonzeroable i) (MIPS.RegisterSet.singleton MIPS.zero) + in + *) + graph + + ) (Obj.magic int_fun.Joint.joint_if_code) graph + in + + (* Done. *) + + graph + diff --git a/extracted/untrusted/build.mli b/extracted/untrusted/build.mli new file mode 100644 index 0000000..3399b10 --- /dev/null +++ b/extracted/untrusted/build.mli @@ -0,0 +1,13 @@ +(* Pasted from Pottier's PP compiler *) + +(** This module builds an interference graph for an [ERTL] function. + This is done by running a liveness analysis and exploiting its + result. [build] returns both the result of the liveness analysis + and the interference graph. *) + +val build: + AST.ident List.list -> + Joint.joint_internal_function -> + Positive.pos Identifiers.identifier_map -> + Fixpoints.valuation -> + Untrusted_interference.graph diff --git a/extracted/untrusted/coloring.ml b/extracted/untrusted/coloring.ml new file mode 100644 index 0000000..653b3c2 --- /dev/null +++ b/extracted/untrusted/coloring.ml @@ -0,0 +1,374 @@ +(* Pasted from Pottier's PP compiler *) + +open ERTL +open Untrusted_interference +open Printf + +(* ------------------------------------------------------------------------- *) +(* Decisions. *) + +(* A decision is of the form either [Spill] -- the vertex could + not be colored and should be spilled into a stack slot -- or + [Color] -- the vertex was assigned a hardware register. *) + +type decision = + | Spill + | Color of I8051.register + +(* +(* [print_decision] turns a decision into a string. *) + +let print_decision = function + | Spill -> + "spilled" + | Color hwr -> + Printf.sprintf "colored $%s" (I8051.print_register hwr) +*) + +(* ------------------------------------------------------------------------- *) +(* Colorings. *) + +(* A coloring is a partial function of graph vertices to decisions. + Vertices that are not in the domain of the coloring are waiting for + a decision to be made. *) + +type coloring = + decision Vertex.Map.t + +(* ------------------------------------------------------------------------- *) +(* Sets of colors. *) + +module ColorSet = + HwRegisterSet + +(* [add_color coloring r colors] returns the union of the set [colors] with + the element [color], if the vertex [r] was assigned color [color], and + returns [colors] if [r] was spilled. *) + +let add_color coloring r colors = + match Vertex.Map.find r coloring with + | Spill -> + colors + | Color color -> + ColorSet.add color colors + +(* These are the colors that we work with. *) + +let colors : ColorSet.t = + Untrusted_interference.hwregisterset_of_list I8051.registersAllocatable + +(* This is the number of available colors. *) + +let k : int = + ColorSet.cardinal colors + +(* ------------------------------------------------------------------------- *) +(* Choices of colors. *) + +(* [forbidden_colors graph coloring v] is the set of colors that cannot be + assigned to [v] considering [coloring], a coloring of every vertex in + [graph] except [v]. *) +(* This takes into account [v]'s possible interferences with hardware + registers, which are viewed as forbidden colors. *) + +let forbidden_colors graph coloring v = + Vertex.Set.fold (add_color coloring) (ipp graph v) (iph graph v) + +(* ------------------------------------------------------------------------- *) +(* Low and high vertices. *) + +(* A vertex is low (or insignificant) if its degree is less than [k]. + It is high (or significant) otherwise. *) + +let high graph v = + degree graph v >= k + +(* [high_neighbors graph v] is the set of all high neighbors of [v]. *) + +let high_neighbors graph v = + Vertex.Set.filter (high graph) (ipp graph v) + +(* ------------------------------------------------------------------------- *) +(* George's conservative coalescing criterion. *) + +(* According to this criterion, two vertices [a] and [b] can be + coalesced, suppressing [a] and keeping [b], if the following + two conditions hold: + + 1. (pseudo-registers) every high neighbor of [a] is a neighbor of [b]; + 2. (hardware registers) every hardware register that interferes with + [a] also interferes with [b]. + + This means that, after all low vertices have been removed, any color that + is suitable for [b] is also suitable for [a]. *) + +let georgepp graph (a, b) = + Vertex.Set.subset (high_neighbors graph a) (ipp graph b) && + HwRegisterSet.subset (iph graph a) (iph graph b) + +(* According to this criterion, a vertex [a] and a hardware register + [c] can be coalesced (that is, [a] can be assigned color [c]) if + every high neighbor of [a] interferes with [c]. *) + +let georgeph graph (a, c) = + Vertex.Set.fold (fun neighbor accu -> + accu && + HwRegisterSet.mem c (iph graph neighbor) + ) (high_neighbors graph a) true + +(* ------------------------------------------------------------------------- *) +(* Here is the coloring algorithm. *) + +module Color (G : sig + + val graph: graph + val uses: Registers.register -> int + val verbose: bool + +end) = struct + + (* The cost function heuristically evaluates how much it might cost + to spill vertex [v]. Here, the cost is the ratio of the number of + uses of the pseudo-registers represented by [v] by the degree of + [v]. One could also take into account the number of nested loops + that the uses appear within, but that is not done here. *) + + let cost graph v = + let uses = + Pset.fold (fun r uses -> + G.uses r + uses + ) (registers graph v) 0 + in + (float_of_int uses) /. (float_of_int (degree graph v)) + + (* The algorithm maintains a transformed graph as it runs. It is + obtained from the original graph by removing, coalescing, and + freezing vertices. *) + + (* Each of the functions that follow returns a coloring of the graph + that it is passed. These functions correspond to the various + states of the algorithm (simplification, coalescing, freezing, + spilling, selection). The function [simplification] is the + initial state. *) + + (* [simplification] removes non-move-related nodes of low degree. *) + + let rec simplification graph : coloring = + + match lowest_non_move_related graph with + + | Some (v, d) when d < k -> + + (* We found a non-move-related node [v] of low degree. Color + the rest of the graph, then color [v]. This is what I call + selection. *) + +(* + if G.verbose then + printf "Simplifying low vertex: %s.\n%!" (print_vertex graph v); +*) + + selection graph v + + | _ -> + + (* There are no non-move-related nodes of low degree. + Could not simplify further. Start coalescing. *) + + coalescing graph + + (* [coalescing] looks for a preference edge that can be collapsed. + It is called after [simplification], so it is known, at this + point, that all nodes of low degree are move-related. *) + + and coalescing graph : coloring = + + (* Find a preference edge between two vertices that passes + George's criterion. + + [pppick] examines all preference edges in the graph, so its use + is inefficient. It would be more efficient instead to examine + only areas of the graph that have changed recently. More + precisely, it is useless to re-examine a preference edge that + did not pass George's criterion the last time it was examined + and whose neighborhood has not been modified by simplification, + coalescing or freezing. Indeed, in that case, and with a + sufficiently large definition of ``neighborhood'', this edge is + guaranteed to again fail George's criterion. It would be + possible to modify the [Interference.graph] data structure so + as to keep track of which neighborhoods have been modified and + provide a specialized, more efficient version of [pppick]. This + is not done here. *) + + match pppick graph (georgepp graph) with + + | Some (a, b) -> + +(* + if G.verbose then + printf "Coalescing %s with %s.\n%!" (print_vertex graph a) (print_vertex graph b); +*) + + (* Coalesce [a] with [b] and color the remaining graph. *) + + let coloring = simplification (coalesce graph a b) in + + (* Assign [a] the same color as [b]. *) + + Vertex.Map.add a (Vertex.Map.find b coloring) coloring + + | None -> + + (* Find a preference edge between a vertex and a hardware + register that passes George's criterion. Like [pppick], + [phpick] is slow. *) + + match phpick graph (georgeph graph) with + + | Some (a, c) -> + +(* + if G.verbose then + printf "Coalescing %s with $%s.\n%!" (print_vertex graph a) (I8051.print_register c); +*) + + (* Coalesce [a] with [c] and color the remaining graph. *) + + let coloring = simplification (coalesceh graph a c) in + + (* Assign [a] the color [c]. *) + + Vertex.Map.add a (Color c) coloring + + | None -> + + (* Could not coalesce further. Start freezing. *) + + freezing graph + + (* [freezing] begins after [simplification] and [coalescing] are + finished, so it is known, at this point, that all nodes of low + degree are move-related and no coalescing is possible. [freezing] + looks for a node of low degree (which must be move-related) and + removes the preference edges that it carries. This potentially + opens new opportunities for simplification and coalescing. *) + + and freezing graph : coloring = + + match lowest graph with + + | Some (v, d) when d < k -> + + (* We found a move-related node [v] of low degree. + Freeze it and start over. *) + +(* + if G.verbose then + printf "Freezing low vertex: %s.\n%!" (print_vertex graph v); +*) + + simplification (freeze graph v) + + | _ -> + + (* Could not freeze further. Start spilling. *) + + spilling graph + + (* [spilling] begins after [simplification], [coalescing], and + [freezing] are finished, so it is known, at this point, that + there are no nodes of low degree. + + Thus, we are facing a potential spill. However, we do optimistic + coloring: we do not spill a vertex right away, but proceed + normally, just as if we were doing simplification. So, we pick a + vertex [v], remove it, and check whether a color can be assigned + to [v] only after coloring what remains of the graph. + + It is crucial to pick a vertex that has few uses in the code. It + would also be good to pick one that has high degree, as this will + help color the rest of the graph. Thus, we pick a vertex that has + minimum cost, where the cost is obtained as the ratio of the + number of uses of the pseudo-registers represented by this vertex + in the code by the degree of the vertex. One could also take into + account the number of nested loops that the uses appear within, + but that is not done here. + + The use of [minimum] is inefficient, because this function + examines all vertices in the graph. It would be possible to + augment the [Interference.graph] data structure so as to keep + track of the cost associated with each vertex and provide + efficient access to a minimum cost vertex. This is not done + here. *) + + and spilling graph : coloring = + + match minimum (cost graph) graph with + | Some v -> + +(* + if G.verbose then + printf "Spilling high vertex: %s.\n%!" (print_vertex graph v); +*) + + selection graph v + + | None -> + + (* The graph is empty. Return an empty coloring. *) + + Vertex.Map.empty + + (* [selection] removes the vertex [v] from the graph, colors the + remaining graph, then selects a color for [v]. + + If [v] is low, that is, if [v] has degree less than [k], then at + least one color must still be available for [v], regardless of + how the remaining graph was colored. + + If [v] was a potential spill, then it is not certain that a color + is still available. If one is, though, then we are rewarded for + being optimistic. If none is, then [v] becomes an actual + spill. *) + + and selection graph v : coloring = + + (* Remove [v] from the graph and color what remains. *) + + let coloring = simplification (remove graph v) in + + (* Determine which colors are allowed. *) + + let allowed = ColorSet.diff colors (forbidden_colors graph coloring v) in + + (* Make a decision. + + We pick a color randomly among those that are allowed. One could + attempt to use biased coloring, that is, to pick a color that seems + desirable (or not undesirable) according to the preference edges + found in the initial graph. But that is probably not worth the + trouble. *) + + let decision = + try + Color (ColorSet.choose allowed) + with Not_found -> + Spill + in + +(* + if G.verbose then + printf "Decision concerning %s: %s.\n%!" (print_vertex graph v) (print_decision decision); +*) + + (* Record our decision and return. *) + + Vertex.Map.add v decision coloring + + (* Run the algorithm. *) + + let coloring = + simplification G.graph + +end + diff --git a/extracted/untrusted/coloring.mli b/extracted/untrusted/coloring.mli new file mode 100644 index 0000000..0fc6630 --- /dev/null +++ b/extracted/untrusted/coloring.mli @@ -0,0 +1,38 @@ +(* Pasted from Pottier's PP compiler *) + +(** This module performs graph coloring. It is used for register + allocation. *) + +(* A coloring is a partial function of graph vertices to decisions, + where a decision is of the form either [Spill] -- the vertex could + not be colored and should be spilled into a stack slot -- or + [Color] -- the vertex was assigned a hardware register. Vertices + that are not in the domain of the coloring are waiting for a + decision to be made. *) + +type decision = + | Spill + | Color of I8051.register + +type coloring = + decision Untrusted_interference.Vertex.Map.t + +(* Here is the coloring algorithm. Out of an interference graph, it + produces a coloring. The client should provide information about + the number of uses of each pseudo-register; the higher the number, + the more undesirable it is to spill that pseudo-register. If the + [verbose] flag is set, the algorithm prints information messages to + the standard output channel. *) + +module Color (G : sig + + val graph: Untrusted_interference.graph + val uses: Registers.register -> int + val verbose: bool + +end) : sig + + val coloring: coloring + +end + diff --git a/extracted/untrusted/compute_colouring.ml b/extracted/untrusted/compute_colouring.ml new file mode 100644 index 0000000..14d4c5e --- /dev/null +++ b/extracted/untrusted/compute_colouring.ml @@ -0,0 +1,65 @@ +(* Adapted from Pottier's PP compiler *) + +let colour_graph globals int_fun liveafter = + (* Build an interference graph for this function, and color + it. Define a function that allows consulting the coloring. *) + + let uses = Uses.examine_internal globals int_fun in + + let module G = struct + let graph = Build.build globals int_fun uses liveafter + let uses = + (fun r -> + Glue.int_of_matitapos + (Identifiers.lookup_safe PreIdentifiers.RegisterTag uses r)) + let verbose = false +(* + let () = + if verbose then + Printf.printf "Starting hardware register allocation for %s.\n" f +*) + end in + + let module C = Coloring.Color (G) in + + let lookup r = + Untrusted_interference.Vertex.Map.find (Untrusted_interference.lookup G.graph r) C.coloring + in + + (* Restrict the interference graph to concern spilled vertices only, + and color it again, this time using stack slots as colors. *) + + let module H = struct + let graph = Untrusted_interference.droph (Untrusted_interference.restrict G.graph (fun v -> + match Untrusted_interference.Vertex.Map.find v C.coloring with + | Coloring.Spill -> + true + | Coloring.Color _ -> + false + )) + let verbose = false +(* + let () = + if verbose then + Printf.printf "Starting stack slot allocation for %s.\n" f +*) + end in + + let module S = Spill.Color (H) in + + (* Define a new function that consults both colorings at once. *) + + let lookup r = + match r with + Types.Inl r -> + (match lookup r with + | Coloring.Spill -> + Interference.Decision_spill (Glue.matitanat_of_int (Untrusted_interference.Vertex.Map.find (Untrusted_interference.lookup H.graph r) S.coloring)) + | Coloring.Color color -> + Interference.Decision_colour color) + | Types.Inr r -> Interference.Decision_colour r + in + + { Interference.colouring = lookup; + spilled_no = Glue.matitanat_of_int S.locals + } diff --git a/extracted/untrusted/compute_colouring.mli b/extracted/untrusted/compute_colouring.mli new file mode 100644 index 0000000..b39f9f2 --- /dev/null +++ b/extracted/untrusted/compute_colouring.mli @@ -0,0 +1,5 @@ +val colour_graph : + AST.ident List.list -> + Joint.joint_internal_function -> + Fixpoints.valuation -> + Interference.coloured_graph diff --git a/extracted/untrusted/compute_fixpoints.ml b/extracted/untrusted/compute_fixpoints.ml new file mode 100644 index 0000000..8ab8fc6 --- /dev/null +++ b/extracted/untrusted/compute_fixpoints.ml @@ -0,0 +1,35 @@ +module Label_ImperativeMap = struct + + type key = Graphs.label + + type 'data t = 'data Graphs.graph ref + + let create () = ref (Identifiers.empty_map PreIdentifiers.LabelTag) + + let clear t = + t := Identifiers.empty_map PreIdentifiers.LabelTag + + let add k d t = + t := Identifiers.add PreIdentifiers.LabelTag !t k d + + let find k t = + match Identifiers.lookup PreIdentifiers.LabelTag !t k with + Types.Some res -> res + | Types.None -> raise Not_found + + let iter f t = + Identifiers.foldi PreIdentifiers.LabelTag (fun k v () -> f k v) !t () + +end + +(** val compute_fixpoint : Fixpoints.fixpoint_computer **) +let compute_fixpoint latt = + let module L : Fix.PROPERTY with type property = Preamble.__ = + struct + type property = Preamble.__ + let bottom = Fixpoints.l_bottom latt + let equal x y = Fixpoints.l_equal latt x y = Bool.True + let is_maximal x = Fixpoints.l_is_maximal latt x = Bool.True + end in + let module F = Fix.Make (Label_ImperativeMap) (L) in + F.lfp diff --git a/extracted/untrusted/compute_fixpoints.mli b/extracted/untrusted/compute_fixpoints.mli new file mode 100644 index 0000000..b0501a3 --- /dev/null +++ b/extracted/untrusted/compute_fixpoints.mli @@ -0,0 +1 @@ +val compute_fixpoint : Fixpoints.fixpoint_computer diff --git a/extracted/untrusted/glue.ml b/extracted/untrusted/glue.ml new file mode 100644 index 0000000..7efe3de --- /dev/null +++ b/extracted/untrusted/glue.ml @@ -0,0 +1,41 @@ +let int_of_bitvector v = + let rec aux pow v = + match v with + Vector.VEmpty -> 0 + | Vector.VCons (_,hd,tl) -> + if hd = Bool.True then + pow + (aux (pow * 2) tl) + else + aux (pow * 2) tl + in + aux 1 (Vector.reverse Nat.O v) + +let rec int_of_matitapos = + function + Positive.One -> 1 + | Positive.P0 v -> int_of_matitapos v * 2 + | Positive.P1 v -> int_of_matitapos v * 2 + 1 + +let int_of_matitaZ = + function + Z.OZ -> 0 + | Z.Pos p -> int_of_matitapos p + | Z.Neg p -> -(int_of_matitapos p) + +let option_of_matitaoption = + function + Types.None -> None + | Types.Some v -> Some v + +let rec matitanat_of_int n = + if n = 0 then Nat.O + else if n < 0 then assert false + else Nat.S (matitanat_of_int (n-1)) + +let rec int_of_matitanat = + function + Nat.O -> 0 + | Nat.S n -> int_of_matitanat n + 1 + +let int_pair_of_pointer { Pointers.pblock = bl ; Pointers.poff = off } = + (int_of_matitaZ bl, int_of_bitvector off) diff --git a/extracted/untrusted/glue.mli b/extracted/untrusted/glue.mli new file mode 100644 index 0000000..2ad8c6a --- /dev/null +++ b/extracted/untrusted/glue.mli @@ -0,0 +1,13 @@ +val int_of_bitvector : BitVector.bitVector -> int + +val int_of_matitapos : Positive.pos -> int + +val int_of_matitaZ : Z.z -> int + +val option_of_matitaoption: 'a Types.option -> 'a option + +val matitanat_of_int : int -> Nat.nat + +val int_of_matitanat : Nat.nat -> int + +val int_pair_of_pointer : Pointers.pointer -> int * int diff --git a/extracted/untrusted/myMap.ml b/extracted/untrusted/myMap.ml new file mode 100644 index 0000000..b6bb364 --- /dev/null +++ b/extracted/untrusted/myMap.ml @@ -0,0 +1,372 @@ +(***********************************************************************) +(* *) +(* 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: myMap.ml,v 1.3 2006/02/17 16:19:52 pottier Exp $ *) + +module type OrderedType = + sig + type t + val compare: t -> t -> int + end + +module type S = + sig + type key + type +'a t + val empty: 'a t + val is_empty: 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val mem: key -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + type interval = key option * key option + val split: interval -> 'a t -> 'a t + val minimum: 'a t -> key * 'a + val find_remove: key -> 'a t -> 'a * 'a t + val update: key -> ('a -> 'a) -> 'a t -> 'a t + val restrict: (key -> bool) -> 'a t -> 'a t + end + +module Make(Ord: OrderedType) = struct + + type key = Ord.t + + type 'a t = + Empty + | Node of 'a t * key * '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) -> + let c = Ord.compare x v in + if c = 0 then + Node(l, x, data, r, h) + else if c < 0 then + bal (add x data l) v d r + else + bal l v d (add x data r) + + (* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + + let rec join l v d r = + match (l, r) with + (Empty, _) -> add v d r + | (_, Empty) -> add v d l + | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> + if lh > rh + 2 then bal ll lv ld (join lr v d r) else + if rh > lh + 2 then bal (join l v d rl) rv rd rr else + create l v d r + + let rec find x = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + if c = 0 then d + else find x (if c < 0 then l else r) + + let rec mem x = function + Empty -> + false + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + c = 0 || mem x (if c < 0 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) -> + let c = Ord.compare x v in + if c = 0 then + merge l r + else if c < 0 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 r (f v d (fold f l accu)) + + type 'a enumeration = End | More of key * '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)) -> + let c = Ord.compare v1 v2 in + if c <> 0 then c 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)) -> + Ord.compare v1 v2 = 0 && cmp d1 d2 && + equal_aux (cons_enum r1 e1) (cons_enum r2 e2) + in equal_aux (cons_enum m1 End) (cons_enum m2 End) + + (* Intervals for splitting. An interval consists of a lower bound + and an upper bound, each of which can be absent. A key is + considered to lie within the interval if it is both greater than + (or equal to) the lower bound (if present) and less than (or + equal to) the upper bound (if present). *) + + type interval = + key option * key option + + (* Splitting. split interval m returns a new map consisting of + all bindings in m whose keys are within interval. *) + + let rec split ((lo, hi) as interval) = function + Empty -> + Empty + | Node(l, v, d, r, _) -> + let clo = Ord.compare v lo in + if clo < 0 then + (* v < lo *) + split interval r + else if clo = 0 then + (* v = lo *) + add v d (splithi hi r) + else + (* v > lo *) + let chi = Ord.compare v hi in + if chi < 0 then + (* v < hi *) + join (splitlo lo l) v d (splithi hi r) + else if chi = 0 then + (* v = hi *) + add v d (splitlo lo l) + else + (* v > hi *) + split interval l + + and splitlo lo = function + Empty -> + Empty + | Node(l, v, d, r, _) -> + let c = Ord.compare v lo in + if c < 0 then + (* v < lo *) + splitlo lo r + else if c = 0 then + (* v = lo *) + add v d r + else + (* v > lo *) + join (splitlo lo l) v d r + + and splithi hi = function + Empty -> + Empty + | Node(l, v, d, r, _) -> + let c = Ord.compare v hi in + if c < 0 then + (* v < hi *) + join l v d (splithi hi r) + else if c = 0 then + (* v = hi *) + add v d l + else + (* v > hi *) + splithi hi l + + (* Splitting. This is the public entry point. *) + + let split interval m = + match interval with + | None, None -> + m + | Some lo, None -> + splitlo lo m + | None, Some hi -> + splithi hi m + | Some lo, Some hi -> + split (lo, hi) m + + (* Finding the minimum key in a map. *) + + let rec minimum key data m = + match m with + | Empty -> + (key, data) + | Node (l, k, d, _, _) -> + minimum k d l + + let minimum = function + | Empty -> + raise Not_found + | Node (l, k, d, _, _) -> + minimum k d l + + (* Finding an element and removing it in one single traversal. *) + + let find_remove x m = + let data = ref None in + let rec remove = function + | Empty -> + raise Not_found + | Node(l, v, d, r, h) -> + let c = Ord.compare x v in + if c = 0 then begin + data := Some d; + merge l r + end + else if c < 0 then + bal (remove l) v d r + else + bal l v d (remove r) + in + let m = remove m in + match !data with + | None -> + assert false + | Some d -> + d, m + + (* Updating the data associated with an element in one single traversal. *) + + exception Unmodified + + let rec update x f m = + let rec update = function + | Empty -> + assert false + | Node(l, v, d, r, h) -> + let c = Ord.compare x v in + if c = 0 then + let d' = f d in + if d == d' then + raise Unmodified + else + Node (l, v, d', r, h) + else if c < 0 then + Node (update l, v, d, r, h) + else + Node (l, v, d, update r, h) + in + try + update m + with Unmodified -> + m + + (* Restricting the domain of a map. *) + + let restrict p m = + fold (fun x d m -> + if p x then + add x d m + else + m + ) m empty + + +end diff --git a/extracted/untrusted/myMap.mli b/extracted/untrusted/myMap.mli new file mode 100644 index 0000000..578bbc4 --- /dev/null +++ b/extracted/untrusted/myMap.mli @@ -0,0 +1,143 @@ +(***********************************************************************) +(* *) +(* 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: myMap.mli,v 1.3 2006/02/17 16:19:52 pottier Exp $ *) + +(** 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. +*) + +module type OrderedType = + sig + type t + (** The type of the map keys. *) + val compare : t -> t -> int + (** A total ordering function over the keys. + This is a two-argument function [f] such that + [f e1 e2] is zero if the keys [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 {!Map.Make}. *) + +module type S = + sig + type key + (** The type of the map keys. *) + + 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: key -> '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: key -> '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: key -> '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: key -> 'a t -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + val iter: (key -> '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: (key -> '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: (key -> '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. *) + + type interval = + key option * key option + (** A type of key intervals. An interval consists of a lower bound + and an upper bound, each of which can be absent. A key is + considered to lie within the interval if it is both greater than + (or equal to) the lower bound (if present) and less than (or + equal to) the upper bound (if present). *) + + val split: interval -> 'a t -> 'a t + (* [split interval m] is a map that consists of all bindings in [m] + whose keys lie within [interval]. *) + + val minimum: 'a t -> key * 'a + (* [minimum m] returns the binding that corresponds to the minimum + (smallest) key within the map [m]. If [m] is empty, [Not_found] + is raised. *) + + val find_remove: key -> 'a t -> 'a * 'a t + (** [find_remove x m] returns a pair of the current binding of [x] + in [m], and a map containing the same bindings as [m], except + for [x] which is unbound in the returned map. [Not_found] is + raised if no binding for [x] exists. *) + + val update: key -> ('a -> 'a) -> 'a t -> 'a t + (** If [m] maps [x] to [d], then [update x f m] maps [x] to [f d] + and coincides with [m] elsewhere. A binding for [x] in [m] + must exist. *) + + val restrict: (key -> bool) -> 'a t -> 'a t + (** [restrict p m] is the restriction of the map [m] to only + the keys that satisfy predicate [p]. *) + + end +(** Output signature of the functor {!Map.Make}. *) + +module Make (Ord : OrderedType) : S with type key = Ord.t +(** Functor building an implementation of the map structure + given a totally ordered type. *) diff --git a/extracted/untrusted/ocamlList.ml b/extracted/untrusted/ocamlList.ml new file mode 100644 index 0000000..5e1df15 --- /dev/null +++ b/extracted/untrusted/ocamlList.ml @@ -0,0 +1,27 @@ +let rec rev_append l1 l2 = + match l1 with + [] -> l2 + | a :: l -> rev_append l (a :: l2) + +let rev l = rev_append l [] + +let find_all p = + let rec find accu = function + | [] -> rev accu + | x :: l -> if p x then find (x :: accu) l else find accu l in + find [] + +let filter = find_all + +let rec map f = function + [] -> [] + | a::l -> let r = f a in r :: map f l + +let rec iter f = function + [] -> () + | a::l -> f a; iter f l + +let rec fold_right f l accu = + match l with + [] -> accu + | a::l -> f a (fold_right f l accu) diff --git a/extracted/untrusted/ocamlString.ml b/extracted/untrusted/ocamlString.ml new file mode 100644 index 0000000..dc319c4 --- /dev/null +++ b/extracted/untrusted/ocamlString.ml @@ -0,0 +1,5 @@ +(* To recover OCaml's String *) + +external length : string -> int = "%string_length" +external get : string -> int -> char = "%string_safe_get" +let compare = Pervasives.compare diff --git a/extracted/untrusted/pmap.ml b/extracted/untrusted/pmap.ml new file mode 100644 index 0000000..62090f5 --- /dev/null +++ b/extracted/untrusted/pmap.ml @@ -0,0 +1,111 @@ +(* Copied from OCaml's Map to make it polymorphic *) + + type ('k,'a) map = + Empty + | Node of ('k,'a) map * 'k * 'a * ('k,'a) map * int + + let empty = Empty + + let height = function + Empty -> 0 + | Node(_,_,_,_,h) -> h + + let rec find x = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + let c = compare x v in + if c = 0 then d + else find x (if c < 0 then l else r) + + 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 rec add x data = function + Empty -> + Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + let c = compare x v in + if c = 0 then + Node(l, x, data, r, h) + else if c < 0 then + bal (add x data l) v d r + else + bal l v d (add x data 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) -> + let c = compare x v in + if c = 0 then + merge l r + else if c < 0 then + bal (remove x l) v d r + else + bal l v d (remove x r) + + let rec fold f m accu = + match m with + Empty -> accu + | Node(l, v, d, r, _) -> + fold f r (f v d (fold f l accu)) + +(* Copied from atom.ml *) + +let restrict p m = + fold (fun x d m -> + if p x then + add x d m + else + m + ) m empty diff --git a/extracted/untrusted/pmap.mli b/extracted/untrusted/pmap.mli new file mode 100644 index 0000000..7fd81a8 --- /dev/null +++ b/extracted/untrusted/pmap.mli @@ -0,0 +1,13 @@ +type ('k,'a) map + +val empty: ('k,'a) map + +val find: 'k -> ('k,'a) map -> 'a + +val add: 'k -> 'a -> ('k,'a) map -> ('k,'a) map + +val remove: 'k -> ('k,'a) map -> ('k,'a) map + +val restrict: ('k -> bool) -> ('k,'a) map -> ('k,'a) map + +val fold: ('k -> 'a -> 'b -> 'b) -> ('k,'a) map -> 'b -> 'b diff --git a/extracted/untrusted/prioritySet.ml b/extracted/untrusted/prioritySet.ml new file mode 100644 index 0000000..7b8b560 --- /dev/null +++ b/extracted/untrusted/prioritySet.ml @@ -0,0 +1,146 @@ +(* Pasted from Pottier's PP compiler *) + +(* This module offers sets of elements where each element carries an + integer priority. All operations execute in logarithmic time with + respect to the number of elements in the set. *) + +module Make (X : Set.OrderedType) += struct + + (* First, define normal sets and maps. *) + + module Set = Set.Make(X) + + module Map = MyMap.Make(X) + + (* Next, define maps of integers to nonempty sets of elements. *) + + module IntMap = struct + + module M = MyMap.Make (struct + type t = int + let compare = compare + end) + + include M + + module H = SetMap.MakeHetero(Set)(M) + + let update = H.update + + end + + (* Now, define priority sets. *) + + type t = { + + (* A mapping of elements to priorities. *) + + priority: int Map.t; + + (* A mapping of priorities to sets of elements. By convention, a + priority has no entry in this table if that entry would be an + empty set of elements. This allows finding the + lowest-priority element in logarithmic time. *) + + level: Set.t IntMap.t + + } + + (* [empty] is the empty set. *) + + let empty = + { + priority = Map.empty; + level = IntMap.empty + } + + (* [priority x s] looks up the priority of element [x]. *) + + let priority x s = + try + Map.find x s.priority + with Not_found -> + assert false + + (* [add x p s] inserts element [x] with priority [p]. *) + + let add x p s = + assert (not (Map.mem x s.priority)); + { + priority = Map.add x p s.priority; + level = IntMap.update p (Set.add x) s.level + } + + (* [remove x s] removes element [x]. *) + + let remove x s = + let p, priority = + try + Map.find_remove x s.priority + with Not_found -> + assert false + in + let level = + IntMap.update p (function xs -> + assert (Set.mem x xs); + Set.remove x xs + ) s.level + in + { + priority = priority; + level = level + } + + (* [change x p s] changes the priority of element [x] to [p]. *) + + let change x p1 s = + let p0 = priority x s in + if p0 = p1 then + s + else + { + priority = Map.add x p1 s.priority; (* overriding previous entry *) + level = IntMap.update p1 (Set.add x) (IntMap.update p0 (Set.remove x) s.level) + } + + (* [increment x d s] increases the priority of element [x] by [d]. *) + + let increment x d s = + change x (priority x s + d) s + + (* [incrementifx x p s] increases the priority of element [x] by [d] + if [x] is a member of the priority set. *) + + let incrementifx x d s = + if Map.mem x s.priority then + increment x d s + else + s + + (* [lowest s] returns [Some (x, p)], where element [x] has minimum + priority [p] among all elements of [s]. It returns [None] if [s] + is empty. *) + + let lowest s = + try + let p, xs = IntMap.minimum s.level in (* can fail if set is empty *) + try + Some (Set.choose xs, p) (* cannot fail *) + with Not_found -> + assert false + with Not_found -> + None + + (* [fold f s accu] fold over the set [s]. Elements are presented + to [f] in increasing order of priority. *) + + let fold f s accu = + IntMap.fold (fun p xs accu -> + Set.fold (fun x accu -> + f x p accu + ) xs accu + ) s.level accu + +end + diff --git a/extracted/untrusted/prioritySet.mli b/extracted/untrusted/prioritySet.mli new file mode 100644 index 0000000..def9028 --- /dev/null +++ b/extracted/untrusted/prioritySet.mli @@ -0,0 +1,54 @@ +(* Pasted from Pottier's PP compiler *) + +(** This module offers sets of elements where each element carries an + integer priority. All operations execute in logarithmic time with + respect to the number of elements in the set. *) + +module Make (X : Set.OrderedType) : sig + + (* This is the type of priority sets. *) + + type t + + (* [empty] is the empty set. *) + + val empty: t + + (* [add x p s] inserts element [x] with priority [p]. *) + + val add: X.t -> int -> t -> t + + (* [remove x s] removes element [x]. *) + + val remove: X.t -> t -> t + + (* [change x p s] changes the priority of element [x] to [p]. *) + + val change: X.t -> int -> t -> t + + (* [increment x d s] increases the priority of element [x] by [d]. *) + + val increment: X.t -> int -> t -> t + + (* [incrementifx x p s] increases the priority of element [x] by [d] + if [x] is a member of the priority set. *) + + val incrementifx: X.t -> int -> t -> t + + (* [priority x s] looks up the priority of element [x]. *) + + val priority: X.t -> t -> int + + (* [lowest s] returns [Some (x, p)], where element [x] has minimum + priority [p] among all elements of [s]. It returns [None] if [s] + is empty. *) + + val lowest: t -> (X.t * int) option + + (* [fold f s accu] fold over the set [s]. Elements are presented + to [f] in increasing order of priority. *) + + val fold: (X.t -> int -> 'a -> 'a) -> t -> 'a -> 'a + +end + diff --git a/extracted/untrusted/pset.ml b/extracted/untrusted/pset.ml new file mode 100644 index 0000000..3c03863 --- /dev/null +++ b/extracted/untrusted/pset.ml @@ -0,0 +1,197 @@ +(* Copied from OCaml's set.ml *) + + type 'a set = Empty | Node of 'a set * 'a * 'a set * int + + let empty = Empty + + let is_empty = function Empty -> true | Node _ -> false + + let height = function + Empty -> 0 + | Node(_, _, _, h) -> h + + let create l v 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, v, r, (if hl >= hr then hl + 1 else hr + 1)) + + let bal l v 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 v r) + else begin + match lr with + Empty -> invalid_arg "Set.bal" + | Node(lrl, lrv, lrr, _)-> + create (create ll lv lrl) lrv (create lrr v 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 v rl) rv rr + else begin + match rl with + Empty -> invalid_arg "Set.bal" + | Node(rll, rlv, rlr, _) -> + create (create l v rll) rlv (create rlr rv rr) + end + end else + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + + let rec add x = function + Empty -> Node(Empty, x, Empty, 1) + | Node(l, v, r, _) as t -> + let c = 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 elt = add elt Empty + + let rec min_elt = function + Empty -> raise Not_found + | Node(Empty, v, r, _) -> v + | Node(l, v, r, _) -> min_elt l + + let rec remove_min_elt = function + Empty -> invalid_arg "Set.remove_min_elt" + | Node(Empty, v, r, _) -> r + | Node(l, v, r, _) -> bal (remove_min_elt l) v r + + let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) + + let rec remove x = function + Empty -> Empty + | Node(l, v, r, _) -> + let c = 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 fold f s accu = + match s with + Empty -> accu + | Node(l, v, r, _) -> fold f r (f v (fold f l accu)) + + let rec iter f = function + Empty -> () + | Node(l, v, r, _) -> iter f l; f v; iter f r + + let rec cardinal = function + Empty -> 0 + | Node(l, v, r, _) -> cardinal l + 1 + cardinal r + + let rec join l v r = + match (l, r) with + (Empty, _) -> add v r + | (_, Empty) -> add v l + | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> + if lh > rh + 2 then bal ll lv (join lr v r) else + if rh > lh + 2 then bal (join l v rl) rv rr else + create l v r + + let rec split x = function + Empty -> + (Empty, false, Empty) + | Node(l, v, r, _) -> + let c = compare x v in + if c = 0 then (l, true, r) + else if c < 0 then + let (ll, pres, rl) = split x l in (ll, pres, join rl v r) + else + let (lr, pres, rr) = split x r in (join l v lr, pres, rr) + + 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 concat t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) + + let rec mem x = function + Empty -> false + | Node(l, v, r, _) -> + let c = compare x v in + c = 0 || mem x (if c < 0 then l else r) + + 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 rec subset s1 s2 = + match (s1, s2) with + Empty, _ -> + true + | _, Empty -> + false + | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> + let c = 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 diff s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, _), t2) -> + match split v1 t2 with + (l2, false, r2) -> + join (diff l1 l2) v1 (diff r1 r2) + | (l2, true, r2) -> + concat (diff l1 l2) (diff r1 r2) + + type 'a enumeration = End | More of 'a * 'a set * 'a enumeration + + let rec cons_enum s e = + match s with + Empty -> e + | Node(l, v, r, _) -> cons_enum l (More(v, r, e)) + + let rec compare_aux e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, r1, e1), More(v2, r2, e2)) -> + let c = compare v1 v2 in + if c <> 0 + then c + else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) + + let compare s1 s2 = + compare_aux (cons_enum s1 End) (cons_enum s2 End) + + let equal s1 s2 = + compare s1 s2 = 0 diff --git a/extracted/untrusted/pset.mli b/extracted/untrusted/pset.mli new file mode 100644 index 0000000..09910df --- /dev/null +++ b/extracted/untrusted/pset.mli @@ -0,0 +1,27 @@ +type 'x set + +val empty : 'a1 set + +val is_empty: 'a1 set -> bool + +val mem : 'a1 -> 'a1 set -> bool + +val add : 'a1 -> 'a1 set -> 'a1 set + +val remove: 'a1 -> 'a1 set -> 'a1 set + +val cardinal: 'a1 set -> int + +val fold: ('a1 -> 'a -> 'a) -> 'a1 set -> 'a -> 'a + +val iter: ('a1 -> unit) -> 'a1 set -> unit + +val equal : 'a1 set -> 'a1 set -> bool + +val diff : 'a1 set -> 'a1 set -> 'a1 set + +val singleton : 'a1 -> 'a1 set + +val subset : 'a1 set -> 'a1 set -> bool + +val union : 'a1 set -> 'a1 set -> 'a1 set diff --git a/extracted/untrusted/setMap.ml b/extracted/untrusted/setMap.ml new file mode 100644 index 0000000..1230080 --- /dev/null +++ b/extracted/untrusted/setMap.ml @@ -0,0 +1,226 @@ +(* Pasted from Pottier's PP compiler *) + +(* This signature defines a few operations over maps of keys to + nonempty sets of items. Keys and items can have distinct types, + hence the name [Heterogeneous]. + + These maps can be used to represent directed bipartite graphs whose + source vertices are keys and whose target vertices are items. Each + key is mapped to the set of its successors. *) + +module type Heterogeneous = sig + + (* These are the types of keys, items, and sets of items. *) + + type key + type item + type itemset + + (* This is the type of maps of keys to sets of items. *) + + type t + + (* [find x m] is the item set associated with key [x] in map [m], if + such an association is defined; it is the empty set otherwise. *) + + val find: key -> t -> itemset + + (* [add x is m] extends [m] with a binding of [x] to the item set + [is], if [is] is nonempty. If [is] is empty, it removes [x] from + [m]. *) + + val add: key -> itemset -> t -> t + + (* [update x f m] is [add x (f (find x m)) m]. *) + + val update: key -> (itemset -> itemset) -> t -> t + + (* [mkedge x i m] extends [m] with a binding of [x] to the union of + the set [m x] and the singleton [i], where [m x] is taken to be + empty if undefined. In terms of graphs, [mkedge x i m] extends + the graph [m] with an edge of [x] to [i]. *) + + val mkedge: key -> item -> t -> t + + (* [rmedge x i m] extends [m] with a binding of [x] to the + difference of the set [m x] and the singleton [i], where the + binding is considered undefined if that difference is empty. In + terms of graphs, [rmedge x i m] removes an edge of [x] to [i] + to the graph [m]. *) + + val rmedge: key -> item -> t -> t + + (* [iter] and [fold] iterate over all edges in the graph. *) + + val iter: (key * item -> unit) -> t -> unit + val fold: (key * item -> 'a -> 'a) -> t -> 'a -> 'a + + (* [pick m p] returns an arbitrary edge that satisfies predicate + [p], if the graph contains one. *) + + val pick: t -> (key * item -> bool) -> (key * item) option + +end + +(* This functor offers an implementation of [Heterogeneous] out of + standard implementations of sets and maps. *) + +module MakeHetero + (Set : sig + type elt + type t + val empty: t + val is_empty: t -> bool + val add: elt -> t -> t + val remove: elt -> t -> t + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + end) + (Map : sig + type key + type 'a t + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end) += struct + + type key = Map.key + type item = Set.elt + type itemset = Set.t + type t = Set.t Map.t + + let find x m = + try + Map.find x m + with Not_found -> + Set.empty + + let add x is m = + if Set.is_empty is then + Map.remove x m + else + Map.add x is m + + let update x f m = + add x (f (find x m)) m + + let mkedge x i m = + update x (Set.add i) m + + let rmedge x i m = + update x (Set.remove i) m + + let fold f m accu = + Map.fold (fun source targets accu -> + Set.fold (fun target accu -> + f (source, target) accu + ) targets accu + ) m accu + + let iter f m = + fold (fun edge () -> f edge) m () + + exception Picked of (key * item) + + let pick m p = + try + iter (fun edge -> + if p edge then + raise (Picked edge) + ) m; + None + with Picked edge -> + Some edge + +end + +(* This signature defines a few common operations over maps of keys + to sets of keys -- that is, keys and items have the same type, + hence the name [Homogeneous]. + + These maps can be used to represent general directed graphs. *) + +module type Homogeneous = sig + + include Heterogeneous (* [key] and [item] intended to be equal *) + + (* [mkbiedge x1 x2 m] is [mkedge x1 x2 (mkedge x2 x1 m)]. *) + + val mkbiedge: key -> key -> t -> t + + (* [rmbiedge x1 x2 m] is [rmedge x1 x2 (rmedge x2 x1 m)]. *) + + val rmbiedge: key -> key -> t -> t + + (* [reverse m] is the reverse of graph [m]. *) + + val reverse: t -> t + + (* [restrict m] is the graph obtained by keeping only the vertices + that satisfy predicate [p]. *) + + val restrict: (key -> bool) -> t -> t + +end + +module MakeHomo + (Set : sig + type elt + type t + val empty: t + val is_empty: t -> bool + val add: elt -> t -> t + val remove: elt -> t -> t + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + val filter: (elt -> bool) -> t -> t + end) + (Map : sig + type key = Set.elt + type 'a t + val empty: 'a t + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end) += struct + + include MakeHetero(Set)(Map) + + let symmetric transform x1 x2 m = + transform x1 x2 (transform x2 x1 m) + + let mkbiedge = + symmetric mkedge + + let rmbiedge = + symmetric rmedge + + let reverse m = + Map.fold (fun source targets predecessors -> + Set.fold (fun target predecessors -> + + (* We have a direct edge from [source] to [target]. Thus, we + record the existence of a reverse edge from [target] to + [source]. *) + + mkedge target source predecessors + + ) targets predecessors + ) m Map.empty + + let restrict p m = + Map.fold (fun source targets m -> + if p source then + let targets = Set.filter p targets in + if Set.is_empty targets then + m + else + Map.add source targets m + else + m + ) m Map.empty + +end + diff --git a/extracted/untrusted/setMap.mli b/extracted/untrusted/setMap.mli new file mode 100644 index 0000000..136310a --- /dev/null +++ b/extracted/untrusted/setMap.mli @@ -0,0 +1,144 @@ +(* Pasted from Pottier's PP compiler *) + +(** This signature defines a few operations over maps of keys to + nonempty sets of items. Keys and items can have distinct types, + hence the name [Heterogeneous]. + + These maps can be used to represent directed bipartite graphs whose + source vertices are keys and whose target vertices are items. Each + key is mapped to the set of its successors. *) + +module type Heterogeneous = sig + + (* These are the types of keys, items, and sets of items. *) + + type key + type item + type itemset + + (* This is the type of maps of keys to sets of items. *) + + type t + + (* [find x m] is the item set associated with key [x] in map [m], if + such an association is defined; it is the empty set otherwise. *) + + val find: key -> t -> itemset + + (* [add x is m] extends [m] with a binding of [x] to the item set + [is], if [is] is nonempty. If [is] is empty, it removes [x] from + [m]. *) + + val add: key -> itemset -> t -> t + + (* [update x f m] is [add x (f (find x m)) m]. *) + + val update: key -> (itemset -> itemset) -> t -> t + + (* [mkedge x i m] extends [m] with a binding of [x] to the union of + the set [m x] and the singleton [i], where [m x] is taken to be + empty if undefined. In terms of graphs, [mkedge x i m] extends + the graph [m] with an edge of [x] to [i]. *) + + val mkedge: key -> item -> t -> t + + (* [rmedge x i m] extends [m] with a binding of [x] to the + difference of the set [m x] and the singleton [i], where the + binding is considered undefined if that difference is empty. In + terms of graphs, [rmedge x i m] removes an edge of [x] to [i] + to the graph [m]. *) + + val rmedge: key -> item -> t -> t + + (* [iter] and [fold] iterate over all edges in the graph. *) + + val iter: (key * item -> unit) -> t -> unit + val fold: (key * item -> 'a -> 'a) -> t -> 'a -> 'a + + (* [pick m p] returns an arbitrary edge that satisfies predicate + [p], if the graph contains one. *) + + val pick: t -> (key * item -> bool) -> (key * item) option + +end + +(* This functor offers an implementation of [Heterogeneous] out of + standard implementations of sets and maps. *) + +module MakeHetero + (Set : sig + type elt + type t + val empty: t + val is_empty: t -> bool + val add: elt -> t -> t + val remove: elt -> t -> t + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + end) + (Map : sig + type key + type 'a t + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end) + : Heterogeneous with type key = Map.key + and type item = Set.elt + and type itemset = Set.t + and type t = Set.t Map.t + +(* This signature defines a few common operations over maps of keys + to sets of keys -- that is, keys and items have the same type, + hence the name [Homogeneous]. + + These maps can be used to represent general directed graphs. *) + +module type Homogeneous = sig + + include Heterogeneous (* [key] and [item] intended to be equal *) + + (* [mkbiedge x1 x2 m] is [mkedge x1 x2 (mkedge x2 x1 m)]. *) + + val mkbiedge: key -> key -> t -> t + + (* [rmbiedge x1 x2 m] is [rmedge x1 x2 (rmedge x2 x1 m)]. *) + + val rmbiedge: key -> key -> t -> t + + (* [reverse m] is the reverse of graph [m]. *) + + val reverse: t -> t + + (* [restrict m] is the graph obtained by keeping only the vertices + that satisfy predicate [p]. *) + + val restrict: (key -> bool) -> t -> t + +end + +module MakeHomo + (Set : sig + type elt + type t + val empty: t + val is_empty: t -> bool + val add: elt -> t -> t + val remove: elt -> t -> t + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + val filter: (elt -> bool) -> t -> t + end) + (Map : sig + type key = Set.elt + type 'a t + val empty: 'a t + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end) + : Homogeneous with type key = Set.elt + and type item = Set.elt + and type itemset = Set.t + and type t = Set.t Map.t + diff --git a/extracted/untrusted/set_adt.ml b/extracted/untrusted/set_adt.ml new file mode 100644 index 0000000..40e3aff --- /dev/null +++ b/extracted/untrusted/set_adt.ml @@ -0,0 +1,31 @@ +type 'x set = 'x Pset.set + +let matitabool_of_bool b = if b then Bool.True else Bool.False + +(** val set_empty : 'a1 set **) +let set_empty = Pset.empty + +(** val set_member : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 -> 'a1 set -> Bool.bool **) +let set_member _ x s = matitabool_of_bool (Pset.mem x s) + +(** val set_equal : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 set -> 'a1 set -> Bool.bool **) +let set_equal _ s1 s2 = matitabool_of_bool (Pset.equal s1 s2) + +(** val set_diff : 'a1 set -> 'a1 set -> 'a1 set **) +let set_diff = Pset.diff + +(** val set_singleton : 'a1 -> 'a1 set **) +let set_singleton = Pset.singleton + +(** val set_from_list : 'a1 List.list -> 'a1 set **) +let set_from_list the_list = + List.foldr Pset.add set_empty the_list + +(** val set_subset : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 set -> 'a1 set -> Bool.bool **) +let set_subset _ s1 s2 = matitabool_of_bool (Pset.subset s1 s2) + +(** val set_union : 'a1 set -> 'a1 set -> 'a1 set **) +let set_union = Pset.union diff --git a/extracted/untrusted/set_adt.mli b/extracted/untrusted/set_adt.mli new file mode 100644 index 0000000..4396ae8 --- /dev/null +++ b/extracted/untrusted/set_adt.mli @@ -0,0 +1,19 @@ +type 'x set + +val set_empty : 'a1 set + +val set_member : ('a1 -> 'a1 -> Bool.bool) -> 'a1 -> 'a1 set -> Bool.bool + +val set_equal : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 set -> 'a1 set -> Bool.bool + +val set_diff : 'a1 set -> 'a1 set -> 'a1 set + +val set_singleton : 'a1 -> 'a1 set + +val set_from_list : 'a1 List.list -> 'a1 set + +val set_subset : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 set -> 'a1 set -> Bool.bool + +val set_union : 'a1 set -> 'a1 set -> 'a1 set diff --git a/extracted/untrusted/spill.ml b/extracted/untrusted/spill.ml new file mode 100644 index 0000000..8edfb45 --- /dev/null +++ b/extracted/untrusted/spill.ml @@ -0,0 +1,159 @@ +(* Pasted from Pottier's PP compiler *) + +open Untrusted_interference +(* open Integer *) +open Printf + +(* ------------------------------------------------------------------------- *) +(* Colorings. *) + +(* This module performs graph coloring with an unlimited number of + colors and aggressive coalescing. It is used for assigning stack + slots to the pseudo-registers that have been spilled by register + allocation. *) + +(* A coloring is a partial function of graph vertices to stack + slots. Vertices that are not in the domain of the coloring are + waiting for a decision to be made. *) + +type decision = + int + +type coloring = + decision Vertex.Map.t + +(* ------------------------------------------------------------------------- *) +(* Here is the coloring algorithm. *) + +module Color (G : sig + + val graph: graph + val verbose: bool + +end) = struct + + module SlotSet = + Set.Make(struct type t = int let compare = Pervasives.compare end) + + (* [forbidden_slots graph coloring v] is the set of stack slots that + cannot be assigned to [v] considering the (partial) coloring + [coloring]. This takes into account [v]'s possible interferences + with other spilled vertices. *) + + let add_slot coloring r slots = + SlotSet.add (Vertex.Map.find r coloring) slots + + let forbidden_slots graph coloring v = + Vertex.Set.fold (add_slot coloring) (ipp graph v) SlotSet.empty + + (* [allocate_slot forbidden] returns a stack slot that is not a + member of the set [forbidden]. Unlike hardware registers, stack + slots are infinitely many, so it is always possible to allocate a + new one. The reference [locals] holds the space that must be + reserved on the stack for locals. *) + + let locals = + ref 0 + + let allocate_slot forbidden = + let rec loop slot = + if SlotSet.mem slot forbidden then + loop (slot + Glue.int_of_bitvector I8051.int_size) + else + slot + in + let slot = loop 0 in + locals := max (slot + Glue.int_of_bitvector I8051.int_size) !locals; + slot + + (* Allocation is in two phases, implemented by [coalescing] and + [simplification]. Each of these functions produces a coloring of its + graph argument. *) + + (* [simplification] expects a graph that does not contain any preference + edges. It picks a vertex [v], removes it, colors the remaining graph, + then colors [v] using a color that is still available. Such a color must + exist, since there is an unlimited number of colors. *) + + (* Following Appel, [v] is chosen with lowest degree: this will make this + vertex easier to color and might (?) help use fewer colors. *) + + let rec simplification graph : coloring = + + match lowest graph with + | Some (v, _) -> + +(* + if G.verbose then + printf "SPILL: Picking vertex: %s.\n" (print_vertex graph v); +*) + + (* Remove [v] from the graph and color what remains. *) + + let coloring = simplification (Untrusted_interference.remove graph v) in + + (* Choose a color for [v]. *) + + let decision = + allocate_slot (forbidden_slots graph coloring v) + in + +(* + if G.verbose then + printf "SPILL: Decision concerning %s: offset %d.\n" (print_vertex graph v) decision; +*) + + (* Record our decision and return. *) + + Vertex.Map.add v decision coloring + + | None -> + + (* The graph is empty. Return an empty coloring. *) + + Vertex.Map.empty + + (* [coalescing] looks for a preference edge, that is, for two vertices + [x] and [y] such that [x] and [y] are move-related. In that case, + [x] and [y] cannot interfere, because the [Interference] module + does not allow two vertices to be related by both an interference + edge and a preference edge. If [coalescing] finds such an edge, it + coalesces [x] and [y] and continues coalescing. Otherwise, it + invokes the next phase, [simplification]. + + This is aggressive coalescing: we coalesce all preference edges, + without fear of creating high-degree nodes. This is good because + a move between two pseudo-registers that have been spilled in + distinct stack slots is very expensive: one load followed by one + store. *) + + let rec coalescing graph : coloring = + + match pppick graph (fun _ -> true) with + | Some (x, y) -> + +(* + if G.verbose then + printf "SPILL: Coalescing %s and %s.\n" (print_vertex graph x) (print_vertex graph y); +*) + + let graph = Untrusted_interference.coalesce graph x y in + let coloring = coalescing graph in + Vertex.Map.add x (Vertex.Map.find y coloring) coloring + + | None -> + + simplification graph + + (* Run the algorithm. [coalescing] runs first and calls [simplification] + when it is done. *) + + let coloring = + coalescing G.graph + + (* Report how much stack space was used. *) + + let locals = + !locals + +end diff --git a/extracted/untrusted/spill.mli b/extracted/untrusted/spill.mli new file mode 100644 index 0000000..79b7184 --- /dev/null +++ b/extracted/untrusted/spill.mli @@ -0,0 +1,36 @@ +(* Pasted from Pottier's PP compiler *) + +(** This module performs graph coloring with an unlimited number of + colors and aggressive coalescing. It is used for assigning stack + slots to the pseudo-registers that have been spilled by register + allocation. *) + +(* A coloring is a partial function of graph vertices to stack + slots. Vertices that are not in the domain of the coloring are + waiting for a decision to be made. *) + +type decision = + int + +type coloring = + decision Untrusted_interference.Vertex.Map.t + +(* Here is the coloring algorithm. Out of an interference graph, it + produces a coloring and reports how many colors (stack slots) were + required. The graph is expected to contain interference and + preferences edges between vertices only -- no hardware registers + are involved. If the [verbose] flag is set, the algorithm prints + information messages to the standard output channel. *) + +module Color (G : sig + + val graph: Untrusted_interference.graph + val verbose: bool + +end) : sig + + val coloring: coloring + val locals: int + +end + diff --git a/extracted/untrusted/untrusted_interference.ml b/extracted/untrusted/untrusted_interference.ml new file mode 100644 index 0000000..598cbd3 --- /dev/null +++ b/extracted/untrusted/untrusted_interference.ml @@ -0,0 +1,873 @@ +type pseudoregister = Registers.register +type hwregister = I8051.register +module HwOrdReg = struct type t = hwregister let compare = compare end +module HwRegisterSet = Set.Make (HwOrdReg) + +let hwregisterset_of_list = + List.foldr + (fun reg set -> HwRegisterSet.add reg set) + HwRegisterSet.empty + +(* Pasted from Pottier's PP compiler *) + +(* This module implements a data structure for interference graphs. + It provides functions that help construct, transform and inspect + interference graphs. *) + +(* ------------------------------------------------------------------------- *) + +(* Vertices are represented as integers. We need sets of vertices, maps over + vertices, maps of vertices to nonempty sets of vertices, maps of vertices + to nonempty sets of hardware registers, and priority sets over vertices. *) + +module Vertex = struct + + module V = struct + type t = Positive.pos + let compare = compare + end + + include V + + module Set = Set.Make(V) + + module Map = MyMap.Make(V) + +end + +module VertexSetMap = + SetMap.MakeHomo(Vertex.Set)(Vertex.Map) + +module I8051RegisterSetMap = + SetMap.MakeHetero(HwRegisterSet)(Vertex.Map) + +module PrioritySet = + PrioritySet.Make(Vertex) + +(* ------------------------------------------------------------------------- *) + +(* Each vertex maps to a set of pseudo-registers, which initially is a + singleton set, but can grow due to coalescing. Conversely, each + pseudo-register maps to a single vertex. *) + +module RegMap : sig + + type t + + (* [empty] is the empty map. *) + + val empty: t + + (* [forward] maps a vertex to a set of pseudo-registers. *) + + val forward: Vertex.t -> t -> pseudoregister Pset.set + + (* [backward] maps a pseudo-register to a vertex. *) + + val backward: pseudoregister -> t -> Vertex.t + + (* [add r v m] adds a relation between pseudo-register [r] and + vertex [v], both of which are assumed fresh. *) + + val add: pseudoregister -> Vertex.t -> t -> t + + (* [fold f m accu] folds over all vertices. *) + + val fold: (Vertex.t -> pseudoregister Pset.set -> 'a -> 'a) -> t -> 'a -> 'a + + (* [coalesce x y m] coalesces vertices [x] and [y]. Vertex [x] is + removed and the pseudo-registers associated with it become + associated with [y] instead. *) + + val coalesce: Vertex.t -> Vertex.t -> t -> t + + (* [remove x m] removes vertex [x]. The pseudo-registers associated + with [x] disappear. *) + + val remove: Vertex.t -> t -> t + + (* [restrict] keeps only those vertices that satisfy predicate [p]. *) + + val restrict: (Vertex.t -> bool) -> t -> t + +end = struct + + type t = { + forward: pseudoregister Pset.set Vertex.Map.t; + backward: (pseudoregister,Vertex.t) Pmap.map + } + + let empty = { + forward = Vertex.Map.empty; + backward = Pmap.empty + } + + let forward v m = + Vertex.Map.find v m.forward + + let backward r m = + try + Pmap.find r m.backward + with Not_found -> + assert false (* bad pseudo-register *) + + let add r v m = { + forward = Vertex.Map.add v (Pset.singleton r) m.forward; + backward = Pmap.add r v m.backward + } + + let fold f m accu = + Vertex.Map.fold f m.forward accu + + let coalesce x y m = + let rx, forward = Vertex.Map.find_remove x m.forward in + let forward = Vertex.Map.update y (Pset.union rx) forward in + let backward = + Pset.fold (fun r backward -> + Pmap.add r y backward + ) rx m.backward + in + { + forward = forward; + backward = backward + } + + let remove x m = + let rx, forward = Vertex.Map.find_remove x m.forward in + let backward = Pset.fold Pmap.remove rx m.backward in + { + forward = forward; + backward = backward + } + + let restrict p m = { + forward = Vertex.Map.restrict p m.forward; + backward = Pmap.restrict (fun r -> p (backward r m)) m.backward + } + +end + +(* ------------------------------------------------------------------------- *) + +(* Graphs. *) + +type graph = { + + (* A two-way correspondence between vertices and pseudo-registers. + This data structure is also used to keep a record of the set of + all vertices. *) + + regmap: RegMap.t; + + (* Interference edges between two vertices: ``these two vertices + cannot receive the same color''. *) + + ivv: VertexSetMap.t; + + (* Interference edges between a vertex and a hardware register: + ``this vertex cannot receive this color''. *) + + ivh: I8051RegisterSetMap.t; + + (* Preference edges between two vertices: ``these two vertices + should preferably receive the same color''. *) + + pvv: VertexSetMap.t; + + (* Preference edges between a vertex and a hardware register: + ``this vertex should preferably receive this color''. *) + + pvh: I8051RegisterSetMap.t; + + (* The degree of each vertex [v], that is, the number of vertices + and hardware registers that [v] interferes with, is recorded at + all times. We use a ``priority set'' so as to be able to + efficiently find a vertex of minimum degree. *) + + degree: PrioritySet.t; + + (* The degree of each *non-move-related* vertex [v]. This + information is partially redundant with the [degree] field + above. It is nevertheless required in order to be able to + efficiently find a *non-move-related* vertex of minimum + degree. *) + + nmr: PrioritySet.t; + + } + +(* ------------------------------------------------------------------------- *) + +(* Our graphs are made up of two subgraphs: the subgraph formed by the + interference edges alone and the one formed by the preference edges + alone. + + In order to allow more code sharing, we define functions that allow + dealing with a single subgraph at a time. They provide operations + such as inspecting the neighbors of a vertex, adding edges, + removing edges, coalescing two vertices, removing a vertex, etc. + + We first define functions that deal with a ``generic'' subgraph, + then (via inheritance) specialize them to deal with the + interference subgraph and the preference subgraph with their + specific features. *) + +class virtual subgraph = object (self) + + (* These methods provide access to the fields of the [graph] data + structure that define the subgraph of interest. All data is + stored in the [graph] data structure. The object [self] has no + state and holds no data. *) + + method virtual getvv: graph -> VertexSetMap.t + method virtual setvv: graph -> VertexSetMap.t -> graph + method virtual getvh: graph -> I8051RegisterSetMap.t + method virtual setvh: graph -> I8051RegisterSetMap.t -> graph + + (* Accessing the neighbors of a vertex and testing whether edges + exist. *) + + method neighborsv graph v = + VertexSetMap.find v (self#getvv graph) + + method existsvv graph v1 v2 = + Vertex.Set.mem v1 (self#neighborsv graph v2) + + method neighborsh graph v = + I8051RegisterSetMap.find v (self#getvh graph) + + method existsvh graph v h = + HwRegisterSet.mem h (self#neighborsh graph v) + + (* [degree graph v] is the degree of vertex [v] with respect to the + subgraph. *) + + method degree graph v = + Vertex.Set.cardinal (self#neighborsv graph v) + HwRegisterSet.cardinal (self#neighborsh graph v) + + (* [hwregs graph] is the set of all hardware registers mentioned in + the subgraph. *) + + method hwregs graph = + let union _ = HwRegisterSet.union in + Vertex.Map.fold union (self#getvh graph) HwRegisterSet.empty + + (* [iter graph fvv fvh] iterates over all edges in the subgraph. + Vertex-to-vertex edges are presented only once. *) + + method iter graph fvv fvh = + Vertex.Map.iter (fun vertex neighbors -> + Vertex.Set.iter (fun neighbor -> + if vertex < neighbor then + fvv vertex neighbor + ) neighbors + ) (self#getvv graph); + Vertex.Map.iter (fun vertex neighbors -> + HwRegisterSet.iter (fun neighbor -> + fvh vertex neighbor + ) neighbors + ) (self#getvh graph) + + (* [mkvv graph v1 v2] adds an edge between vertices [v1] and [v2]. *) + + method mkvv graph v1 v2 = + if v1 = v2 then + graph (* avoid creating self-edge *) + else if self#existsvv graph v1 v2 then + graph (* avoid re-adding an existing edge *) + else + self#mkvvi graph v1 v2 + + method mkvvi graph v1 v2 = + self#setvv graph (VertexSetMap.mkbiedge v1 v2 (self#getvv graph)) + + (* [rmvv graph v1 v2] removes an edge between vertices [v1] and [v2]. + [rmvvifx] removes an edge if it exists. *) + + method rmvv graph v1 v2 = + assert (self#existsvv graph v1 v2); + self#setvv graph (VertexSetMap.rmbiedge v1 v2 (self#getvv graph)) + + method rmvvifx graph v1 v2 = + if self#existsvv graph v1 v2 then + self#rmvv graph v1 v2 + else + graph + + (* [mkvh graph v h] adds an edge between vertex [v] and hardware + register [h]. *) + + method mkvh graph v h = + if self#existsvh graph v h then + graph (* avoid re-adding an existing edge *) + else + self#mkvhi graph v h + + method mkvhi graph v h = + self#setvh graph (I8051RegisterSetMap.update v (HwRegisterSet.add h) (self#getvh graph)) + + (* [rmvh v h] removes an edge between vertex [v] and hardware + register [h]. [rmvhifx] removes an edge if it exists. *) + + method rmvh graph v h = + assert (self#existsvh graph v h); + self#setvh graph (I8051RegisterSetMap.update v (HwRegisterSet.remove h) (self#getvh graph)) + + method rmvhifx graph v h = + if self#existsvh graph v h then + self#rmvh graph v h + else + graph + + (* [coalesce graph x y] turns every neighbor [w] or [h] of [x] into + a neighbor of [y] instead. [w] ranges over both vertices and + hardware registers. *) + + method coalesce graph x y = + let graph = + Vertex.Set.fold (fun w graph -> + self#mkvv (self#rmvv graph x w) y w + ) (self#neighborsv graph x) graph + in + let graph = + HwRegisterSet.fold (fun h graph -> + self#mkvh (self#rmvh graph x h) y h + ) (self#neighborsh graph x) graph + in + graph + + (* [coalesceh graph x h] turns every neighbor [w] of [x] into a + neighbor of [h] instead. [w] ranges over both vertices and + hardware registers. Edges between two hardware registers are not + recorded. *) + + method coalesceh graph x h = + let graph = + Vertex.Set.fold (fun w graph -> + self#mkvh (self#rmvv graph x w) w h + ) (self#neighborsv graph x) graph + in + let graph = + HwRegisterSet.fold (fun k graph -> + self#rmvh graph x k + ) (self#neighborsh graph x) graph + in + graph + + (* [remove graph x] removes all edges carried by vertex [x]. *) + + method remove graph x = + let graph = + Vertex.Set.fold (fun w graph -> + self#rmvv graph x w + ) (self#neighborsv graph x) graph + in + let graph = + HwRegisterSet.fold (fun h graph -> + self#rmvh graph x h + ) (self#neighborsh graph x) graph + in + graph + +end + +(* ------------------------------------------------------------------------- *) + +(* The interference subgraph. + + This is a subgraph with the following specific features: (1) the + degree of every vertex is recorded in the [degree] field of the + [graph] data structure; (2) the degree of every non-move-related + vertex is recorded in the [nmr] field of the [graph] data + structure; (3) creating an edge in the interference subgraph + automatically destroys a corresponding edge in the preference + subgraph. *) + +class interference (preference : preference Lazy.t) = object (self) + + inherit subgraph as super + + method getvv graph = graph.ivv + method setvv graph m = { graph with ivv = m } + method getvh graph = graph.ivh + method setvh graph m = { graph with ivh = m } + + (* Override the edge creation and destruction methods. *) + + method mkvvi graph v1 v2 = + let graph = super#mkvvi graph v1 v2 in + let graph = (Lazy.force preference)#rmvvifx graph v1 v2 in (* do not constrain an existing preference edge *) + { graph with + degree = PrioritySet.increment v1 1 (PrioritySet.increment v2 1 graph.degree); + nmr = PrioritySet.incrementifx v1 1 (PrioritySet.incrementifx v2 1 graph.nmr); + } + + method rmvv graph v1 v2 = + let graph = super#rmvv graph v1 v2 in + { graph with + degree = PrioritySet.increment v1 (-1) (PrioritySet.increment v2 (-1) graph.degree); + nmr = PrioritySet.incrementifx v1 (-1) (PrioritySet.incrementifx v2 (-1) graph.nmr); + } + + method mkvhi graph v h = + let graph = super#mkvhi graph v h in + let graph = (Lazy.force preference)#rmvhifx graph v h in (* do not constrain an existing preference edge *) + { graph with + degree = PrioritySet.increment v 1 graph.degree; + nmr = PrioritySet.incrementifx v 1 graph.nmr; + } + + method rmvh graph v h = + let graph = super#rmvh graph v h in + { graph with + degree = PrioritySet.increment v (-1) graph.degree; + nmr = PrioritySet.incrementifx v (-1) graph.nmr; + } + +end + +(* ------------------------------------------------------------------------- *) + +(* The preference subgraph. + + This is a subgraph with the following specific features: (1) an + edge in the preference subgraph cannot be created if a + corresponding edge exists in the interference subgraph; (2) adding + an edge can make a vertex move-related, which requires taking that + vertex out of the [nmr] set; conversely, removing an edge can make + a vertex non-move-related, which requires adding that vertex to the + [nmr] set. *) + +and preference (interference : interference Lazy.t) = object (self) + + inherit subgraph as super + + method getvv graph = graph.pvv + method setvv graph m = { graph with pvv = m } + method getvh graph = graph.pvh + method setvh graph m = { graph with pvh = m } + + (* [nmr graph v] tells whether vertex [v] is non-move-related. *) + + method nmr graph v = + Vertex.Set.is_empty (self#neighborsv graph v) && + HwRegisterSet.is_empty (self#neighborsh graph v) + + (* [mkcheck graph v] moves [v] out of the [nmr] set if [v] is + non-move-related. *) + + method mkcheck graph v = + if self#nmr graph v then + { graph with + nmr = PrioritySet.remove v graph.nmr } + else + graph + + (* Override the edge creation methods. *) + + method mkvvi graph v1 v2 = + if (Lazy.force interference)#existsvv graph v1 v2 then + graph (* avoid creating constrained preference edge *) + else + let graph = self#mkcheck graph v1 in + let graph = self#mkcheck graph v2 in + super#mkvvi graph v1 v2 + + method mkvhi graph v h = + if (Lazy.force interference)#existsvh graph v h then + graph (* avoid creating constrained preference edge *) + else + let graph = self#mkcheck graph v in + super#mkvhi graph v h + + (* [rmcheck graph v] moves [v] into the [nmr] set if [v] is + non-move-related. *) + + method rmcheck graph v = + if self#nmr graph v then + { graph with + nmr = PrioritySet.add v (PrioritySet.priority v graph.degree) graph.nmr + } + else + graph + + (* Override the edge destruction methods. *) + + method rmvv graph v1 v2 = + let graph = super#rmvv graph v1 v2 in + let graph = self#rmcheck graph v1 in + let graph = self#rmcheck graph v2 in + graph + + method rmvh graph v h = + let graph = super#rmvh graph v h in + let graph = self#rmcheck graph v in + graph + +end + +(* ------------------------------------------------------------------------- *) + +(* Because the interference and preference subgraphs are mutually + referential, a recursive definition is required. It is made + somewhat inelegant by Objective Caml's insistence on using the + [Lazy] mechanism. *) + +let rec interference = lazy (new interference preference) + and preference = lazy (new preference interference) +let interference = Lazy.force interference +let preference = Lazy.force preference + +(* ------------------------------------------------------------------------- *) + +(* Inspecting interference graphs. *) + +(* [ipp graph v] is the set of vertices that the vertex [v] interferes + with. *) + +let ipp graph v = + interference#neighborsv graph v + +(* [iph graph v] is the set of hardware registers that the vertex [v] + interferes with. *) + +let iph graph v = + interference#neighborsh graph v + +(* [ppp graph v] is the set of vertices that should preferably be + assigned the same color as the vertex [v]. *) + +let ppp graph v = + preference#neighborsv graph v + +(* [pph graph v] is the set of hardware registers that [v] should + preferably be assigned. *) + +let pph graph v = + preference#neighborsh graph v + +(* [degree graph v] is the degree of the vertex [v], that is, the number + of vertices and hardware registers that [v] interferes with. *) + +let degree graph v = + PrioritySet.priority v graph.degree + +(* [lowest graph] returns [Some (v, d)], where the vertex [v] has + minimum degree [d], or returns [None] if the graph is empty. *) + +let lowest graph = + PrioritySet.lowest graph.degree + +(* [lowest_non_move_related graph] returns [Some (v, d)], where the + vertex [v] has minimum degree [d] among the vertices that are not + move-related, or returns [None] if all vertices are move-related. A + vertex is move-related if it carries a preference edge. *) + +let lowest_non_move_related graph = + PrioritySet.lowest graph.nmr + +(* [fold f graph accu] folds over all vertices. *) + +let fold f graph accu = + RegMap.fold (fun v _ accu -> f v accu) graph.regmap accu + +(* [minimum f graph] returns a vertex [v] such that the value of [f x] + is minimal. The values returned by [f] are compared using Objective + Caml's generic comparison operator [<]. If the graph is empty, + [None] is returned. *) + +let minimum f graph = + match + fold (fun w accu -> + let dw = f w in + match accu with + | None -> + Some (dw, w) + | Some (dv, v) -> + if dw < dv then + Some (dw, w) + else + accu + ) graph None + with + | None -> + None + | Some (_, v) -> + Some v + +(* [pppick graph p] returns an arbitrary preference edge that + satisfies the predicate [p], if the graph contains one. *) + +type ppedge = + Vertex.t * Vertex.t + +let pppick graph p = + VertexSetMap.pick graph.pvv p + +(* [phpick graph p] returns an arbitrary preference edge that + satisfies the predicate [p], if the graph contains one. *) + +type phedge = + Vertex.t * I8051.register + +let phpick graph p = + I8051RegisterSetMap.pick graph.pvh p + +(* ------------------------------------------------------------------------- *) + +(* Constructing interference graphs. *) + +(* [create regs] creates an interference graph whose vertices are + the pseudo-registers [regs] and that does not have any edges. *) + +let create regs = + let _, regmap, degree = + Pset.fold (fun r (v, regmap, degree) -> + Positive.succ v, + RegMap.add r v regmap, + PrioritySet.add v 0 degree + ) regs (Positive.One, RegMap.empty, PrioritySet.empty) + in + { + regmap = regmap; + ivv = Vertex.Map.empty; + ivh = Vertex.Map.empty; + pvv = Vertex.Map.empty; + pvh = Vertex.Map.empty; + degree = degree; + nmr = degree + } + +(* [lookup graph r] returns the graph vertex associated with + pseudo-register [r]. *) + +let lookup graph r = + RegMap.backward r graph.regmap + +(* Conversely, [registers graph v] returns the set of pseudo-registers + associated with vertex [v]. *) + +let registers graph v = + RegMap.forward v graph.regmap + +(* [mkipp graph regs1 regs2] adds interference edges between all pairs + of pseudo-registers [r1] and [r2], where [r1] ranges over [regs1], + [r2] ranges over [regs2], and [r1] and [r2] are distinct. *) + +let mkipp graph regs1 regs2 = + Pset.fold (fun r1 graph -> + let v1 = lookup graph r1 in + Pset.fold (fun r2 graph -> + interference#mkvv graph v1 (lookup graph r2) + ) regs2 graph + ) regs1 graph + +(* [mkiph graph regs hwregs] adds interference edges between all pairs + of a pseudo-register [r] and a hardware register [hwr], where [r] + ranges over [regs] and [hwr] ranges over [hwregs]. *) + +let mkiph graph regs hwregs = + Pset.fold (fun r graph -> + let v = lookup graph r in + HwRegisterSet.fold (fun h graph -> + interference#mkvh graph v h + ) hwregs graph + ) regs graph + +(* [mki graph regs1 regs2] adds interference edges between all pairs + of (pseudo- or hardware) registers [r1] and [r2], where [r1] ranges + over [regs1], [r2] ranges over [regs2], and [r1] and [r2] are + distinct. *) + +let mki graph (regs1, hwregs1) (regs2, hwregs2) = + let graph = mkipp graph regs1 regs2 in + let graph = mkiph graph regs1 hwregs2 in + let graph = mkiph graph regs2 hwregs1 in + graph + +(* [mkppp graph r1 r2] adds a preference edge between the + pseudo-registers [r1] and [r2]. *) + +let mkppp graph r1 r2 = + let v1 = lookup graph r1 + and v2 = lookup graph r2 in + let graph = preference#mkvv graph v1 v2 in + graph + +(* [mkpph graph r h] adds a preference edge between the + pseudo-register [r] and the hardware register [h]. *) + +let mkpph graph r h = + let v = lookup graph r in + let graph = preference#mkvh graph v h in + graph + +(* ------------------------------------------------------------------------- *) + +(* +(* Displaying interference graphs. *) + +open Printf + +let hwregs graph = + HwRegisterSet.union (interference#hwregs graph) (preference#hwregs graph) + +let print_vertex graph v = + Pset.print (registers graph v) + +let print f graph = + + fprintf f "graph G {\n"; +(* fprintf f "size=\"6, 3\";\n"; (* in inches *)*) + fprintf f "orientation = landscape;\n"; + fprintf f "rankdir = LR;\n"; + fprintf f "ratio = compress;\n\n"; (* compress or fill or auto *) + + RegMap.fold (fun vertex regs () -> + fprintf f "r%d [ label=\"%s\" ] ;\n" vertex (Pset.print regs) + ) graph.regmap (); + + HwRegisterSet.iter (fun hwr -> + let name = I8051.print_register hwr in + fprintf f "hwr%s [ label=\"$%s\" ] ;\n" name name + ) (hwregs graph); + + interference#iter graph + (fun vertex neighbor -> + fprintf f "r%d -- r%d ;\n" vertex neighbor) + (fun vertex neighbor -> + fprintf f "r%d -- hwr%s ;\n" vertex (I8051.print_register neighbor)); + + preference#iter graph + (fun vertex neighbor -> + fprintf f "r%d -- r%d [ style = dashed ] ;\n" vertex neighbor) + (fun vertex neighbor -> + fprintf f "r%d -- hwr%s [ style = dashed ] ;\n" vertex (I8051.print_register neighbor)); + + fprintf f "\n}\n" +*) + +(* ------------------------------------------------------------------------- *) + +(* Coalescing. *) + +(* [coalesce graph v1 v2] is a new graph where the vertices [v1] and [v2] + are coalesced. The new coalesced vertex is known under the name [v2]. *) + +let coalesce graph x y = + + assert (x <> y); (* attempt to coalesce one vertex with itself *) + assert (not (interference#existsvv graph x y)); (* attempt to coalesce two interfering vertices *) + + (* Perform coalescing in the two subgraphs. *) + + let graph = interference#coalesce graph x y in + let graph = preference#coalesce graph x y in + + (* Remove [x] from all tables. *) + + { + graph with + regmap = RegMap.coalesce x y graph.regmap; + ivh = Vertex.Map.remove x graph.ivh; + pvh = Vertex.Map.remove x graph.pvh; + degree = PrioritySet.remove x graph.degree; + nmr = PrioritySet.remove x graph.nmr; + } + +(* [coalesceh graph v h] coalesces the vertex [v] with the hardware register + [h]. This produces a new graph where [v] no longer exists and all edges + leading to [v] are replaced with edges leading to [h]. *) + +let coalesceh graph x h = + + assert (not (interference#existsvh graph x h)); (* attempt to coalesce interfering entities *) + + (* Perform coalescing in the two subgraphs. *) + + let graph = interference#coalesceh graph x h in + let graph = preference#coalesceh graph x h in + + (* Remove [x] from all tables. *) + + { + graph with + regmap = RegMap.remove x graph.regmap; + ivh = Vertex.Map.remove x graph.ivh; + pvh = Vertex.Map.remove x graph.pvh; + degree = PrioritySet.remove x graph.degree; + nmr = PrioritySet.remove x graph.nmr; + } + +(* ------------------------------------------------------------------------- *) + +(* [freeze graph x] is a new graph where all preference edges carried + by [x] are removed. *) + +let freeze graph x = + preference#remove graph x + +(* ------------------------------------------------------------------------- *) + +(* Removal. *) + +(* [remove graph v] is a new graph where vertex [v] is removed. *) + +let remove graph v = + + (* Remove all edges carried by [v]. *) + + let graph = interference#remove graph v in + let graph = preference#remove graph v in + + (* Remove [v] from all tables. *) + + { + graph with + regmap = RegMap.remove v graph.regmap; + degree = PrioritySet.remove v graph.degree; + nmr = PrioritySet.remove v graph.nmr; + } + +(* ------------------------------------------------------------------------- *) + +(* [mkdeg graph] recomputes degree information from scratch. *) + +let mkdeg graph = + let degree, nmr = + fold (fun v (degree, nmr) -> + let d = interference#degree graph v in + PrioritySet.add v d degree, + if preference#nmr graph v then PrioritySet.add v d nmr else nmr + ) graph (PrioritySet.empty, PrioritySet.empty) + in + { graph with + degree = degree; + nmr = nmr; + } + +(* [restrict graph p] is a new graph where only those vertices that + satisfy predicate [p] are kept. The same effect could be obtained + by repeated application of [remove], but [restrict] is likely to be + more efficient if many vertices are removed. *) + +let restrict graph p = + mkdeg { + graph with + regmap = RegMap.restrict p graph.regmap; + ivv = VertexSetMap.restrict p graph.ivv; + ivh = Vertex.Map.restrict p graph.ivh; + pvv = VertexSetMap.restrict p graph.pvv; + pvh = Vertex.Map.restrict p graph.pvh; + } + +(* [droph graph] is a new graph where all information concerning hardware + registers has been dropped. *) + +let droph graph = + mkdeg { + graph with + ivh = Vertex.Map.empty; + pvh = Vertex.Map.empty; + } + diff --git a/extracted/untrusted/untrusted_interference.mli b/extracted/untrusted/untrusted_interference.mli new file mode 100644 index 0000000..d102989 --- /dev/null +++ b/extracted/untrusted/untrusted_interference.mli @@ -0,0 +1,220 @@ +type pseudoregister = Registers.register +type hwregister = I8051.register +module HwRegisterSet : Set.S with type elt = hwregister + +val hwregisterset_of_list : hwregister List.list -> HwRegisterSet.t + +(* Pasted from Pottier's PP compiler *) + +(** This module implements a data structure for interference graphs. + It provides functions that help construct, transform and inspect + interference graphs. *) + +(* Interference graphs record two kinds of edges: interference edges + (``these two vertices cannot receive the same color'') and + preference edges (``these two vertices should preferably receive + the same color''). Furthermore, each kind of edge can relate either + two pseudo-registers or one pseudo-register and one hardware + register. Thus, an interference graph keeps track of four kinds of + relationships. + + This module automatically maintains the invariant that two vertices + [x] and [y] cannot be related by both an interference edge and a + preference edge. When such a situation appears (for instance, + because of coalescing), the preference edge is automatically + removed. *) + +type graph + +(* The vertices of an interference graph initially correspond to + pseudo-registers. However, interference graphs support coalescing, + which means that a new graph can be constructed by coalescing two + vertices in an existing graph. As a result, in general, the vertices + of an interference graph correspond to sets of pseudo-registers. *) + +(* ------------------------------------------------------------------------- *) + +(* Operations over vertices: sets of vertices, maps over vertices. *) + +module Vertex : sig + + type t + + (* The usual operations on sets, see [Set.S] in Objective Caml's + documentation. *) + + module Set : Set.S with type elt = t + + (* The usual operations on maps, see [Map.S] in Objective Caml's + documentation. One slight difference is that [find] expects + the key to be present in the map -- it will fail otherwise. *) + + module Map : MyMap.S with type key = t + +end + +(* ------------------------------------------------------------------------- *) + +(* Building interference graphs. *) + +(* [create regs] creates an interference graph whose vertices are + the pseudo-registers [regs] and that does not have any edges. *) + +val create: pseudoregister Pset.set -> graph + +(* [mki graph regs1 regs2] adds interference edges between all pairs + of (pseudo- or hardware) registers [r1] and [r2], where [r1] ranges + over [regs1], [r2] ranges over [regs2], and [r1] and [r2] are + distinct. *) + +val mki: graph -> + pseudoregister Pset.set * HwRegisterSet.t -> + pseudoregister Pset.set * HwRegisterSet.t -> + graph + +(* [mkiph graph regs hwregs] adds interference edges between all pairs + of a pseudo-register [r] and a hardware register [hwr], where [r] + ranges over [regs] and [hwr] ranges over [hwregs]. *) + +val mkiph: graph -> pseudoregister Pset.set -> HwRegisterSet.t -> graph + +(* [mkppp graph r1 r2] adds a preference edge between the + pseudo-registers [r1] and [r2]. *) + +val mkppp: graph -> pseudoregister -> pseudoregister -> graph + +(* [mkpph graph r h] adds a preference edge between the + pseudo-register [r] and the hardware register [h]. *) + +val mkpph: graph -> pseudoregister -> hwregister -> graph + +(* ------------------------------------------------------------------------- *) + +(* Transforming interference graphs. *) + +(* [coalesce graph v1 v2] is a new graph where the vertices [v1] and + [v2] are coalesced. [v1] and [v2] must not interfere. The new + coalesced vertex is known under the name [v2]. *) + +val coalesce: graph -> Vertex.t -> Vertex.t -> graph + +(* [coalesceh graph v h] coalesces the vertex [v] with the hardware register + [h]. This produces a new graph where [v] no longer exists and all edges + leading to [v] are replaced with edges leading to [h]. *) + +val coalesceh: graph -> Vertex.t -> I8051.register -> graph + +(* [remove graph v] is a new graph where vertex [v] is removed. *) + +val remove: graph -> Vertex.t -> graph + +(* [freeze graph x] is a new graph where all preference edges carried + by [x] are removed. *) + +val freeze: graph -> Vertex.t -> graph + +(* [restrict graph p] is a new graph where only those vertices that + satisfy predicate [p] are kept. *) + +val restrict: graph -> (Vertex.t -> bool) -> graph + +(* [droph graph] is a new graph where all information concerning hardware + registers has been dropped. *) + +val droph: graph -> graph + +(* ------------------------------------------------------------------------- *) + +(* Inspecting interference graphs. *) + +(* [lookup graph r] returns the graph vertex associated with + pseudo-register [r]. *) + +val lookup: graph -> pseudoregister -> Vertex.t + +(* Conversely, [registers graph v] returns the set of pseudo-registers + associated with vertex [v]. *) + +val registers: graph -> Vertex.t -> pseudoregister Pset.set + +(* [degree graph v] is the degree of the vertex [v], that is, the number + of vertices and hardware registers that [v] interferes with. *) + +val degree: graph -> Vertex.t -> int + +(* [lowest graph] returns [Some (v, d)], where the vertex [v] has + minimum degree [d], or returns [None] if the graph is empty. *) + +val lowest: graph -> (Vertex.t * int) option + +(* [lowest_non_move_related graph] returns [Some (v, d)], where the + vertex [v] has minimum degree [d] among the vertices that are not + move-related, or returns [None] if all vertices are move-related. A + vertex is move-related if it carries a preference edge. *) + +val lowest_non_move_related: graph -> (Vertex.t * int) option + +(* [minimum f graph] returns a vertex [v] such that the value of [f x] + is minimal. The values returned by [f] are compared using Objective + Caml's generic comparison operator [<]. If the graph is empty, + [None] is returned. *) + +val minimum: (Vertex.t -> 'a) -> graph -> Vertex.t option + +(* [fold f graph accu] folds over all vertices. *) + +val fold: (Vertex.t -> 'a -> 'a) -> graph -> 'a -> 'a + +(* [ipp graph v] is the set of vertices that the vertex [v] interferes + with. *) + +val ipp: graph -> Vertex.t -> Vertex.Set.t + +(* [iph graph v] is the set of hardware registers that the vertex [v] + interferes with. *) + +val iph: graph -> Vertex.t -> HwRegisterSet.t + +(* [ppp graph v] is the set of vertices that should preferably be + assigned the same color as the vertex [v]. *) + +val ppp: graph -> Vertex.t -> Vertex.Set.t + +(* [pph graph v] is the set of hardware registers that [v] should + preferably be assigned. *) + +val pph: graph -> Vertex.t -> HwRegisterSet.t + +(* [pppick graph p] returns an arbitrary preference edge that + satisfies the predicate [p], if the graph contains one. *) + +type ppedge = + Vertex.t * Vertex.t + +val pppick: graph -> (ppedge -> bool) -> ppedge option + +(* [phpick graph p] returns an arbitrary preference edge that + satisfies the predicate [p], if the graph contains one. *) + +type phedge = + Vertex.t * I8051.register + +val phpick: graph -> (phedge -> bool) -> phedge option + +(* +(* ------------------------------------------------------------------------- *) + +(* Displaying interference graphs. *) + +(* [print_vertex graph v] produces a string representation of the + vertex [v]. *) + +val print_vertex: graph -> Vertex.t -> string + +(* [print f graph] prints a representation of the interference graph + [graph] in [dot] format to the output channel [f]. Interference + edges are drawn as plain lines; preference edges are drawn as + dotted lines. *) + +val print: out_channel -> graph -> unit +*) diff --git a/extracted/uses.ml b/extracted/uses.ml new file mode 100644 index 0000000..79488b2 --- /dev/null +++ b/extracted/uses.ml @@ -0,0 +1,192 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open ERTL + +(** val examine_internal : + AST.ident List.list -> Joint.joint_internal_function -> Positive.pos + Identifiers.identifier_map **) +let examine_internal globals fun0 = + let incr = fun r map -> + match Identifiers.lookup PreIdentifiers.RegisterTag map r with + | Types.None -> + Identifiers.add PreIdentifiers.RegisterTag map r Positive.One + | Types.Some v -> + Identifiers.add PreIdentifiers.RegisterTag map r (Positive.succ v) + in + let incr_arg = fun arg map -> + match arg with + | Joint.Reg r -> incr r map + | Joint.Imm x -> map + in + let f = fun x instr map -> + match instr with + | Joint.Sequential (s, x0) -> + (match s with + | Joint.COST_LABEL x1 -> map + | Joint.CALL (id, x1, x2) -> + (match id with + | Types.Inl x3 -> map + | Types.Inr pr -> + Obj.magic incr_arg pr.Types.fst + (Obj.magic incr_arg pr.Types.snd map)) + | Joint.COND (r, x1) -> Obj.magic incr r map + | Joint.Step_seq s0 -> + (match s0 with + | Joint.COMMENT x1 -> map + | Joint.MOVE pair -> + let { Types.fst = r1; Types.snd = r2 } = Obj.magic pair in + let incr_dst = fun arg map0 -> + match arg with + | ERTL.PSD r -> incr r map0 + | ERTL.HDW x1 -> map0 + in + incr_dst r1 + (match r2 with + | Joint.Reg a -> incr_dst a map + | Joint.Imm x1 -> map) + | Joint.POP r -> Obj.magic incr r map + | Joint.PUSH r -> Obj.magic incr_arg r map + | Joint.ADDRESS (x1, x3, x4, x5) -> map + | Joint.OPACCS (x1, r1, r2, r3, r4) -> + Obj.magic incr r1 + (Obj.magic incr r2 + (Obj.magic incr_arg r3 (Obj.magic incr_arg r4 map))) + | Joint.OP1 (x1, r1, r2) -> + Obj.magic incr r1 (Obj.magic incr r2 map) + | Joint.OP2 (x1, r1, r2, r3) -> + Obj.magic incr r1 + (Obj.magic incr_arg r2 (Obj.magic incr_arg r3 map)) + | Joint.CLEAR_CARRY -> map + | Joint.SET_CARRY -> map + | Joint.LOAD (r1, x1, x2) -> Obj.magic incr r1 map + | Joint.STORE (x1, x2, r) -> Obj.magic incr_arg r map + | Joint.Extension_seq s1 -> + (match Obj.magic s1 with + | ERTL.Ertl_new_frame -> map + | ERTL.Ertl_del_frame -> map + | ERTL.Ertl_frame_size r -> incr r map))) + | Joint.Final x0 -> map + | Joint.FCOND (x0, x1, x2) -> assert false (* absurd case *) + in + Identifiers.foldi PreIdentifiers.LabelTag f + (Obj.magic fun0.Joint.joint_if_code) + (Identifiers.empty_map PreIdentifiers.RegisterTag) + diff --git a/extracted/uses.mli b/extracted/uses.mli new file mode 100644 index 0000000..4567ffb --- /dev/null +++ b/extracted/uses.mli @@ -0,0 +1,126 @@ +open Preamble + +open Extra_bool + +open Coqlib + +open Values + +open FrontEndVal + +open GenMem + +open FrontEndMem + +open Globalenvs + +open String + +open Sets + +open Listb + +open LabelledObjects + +open BitVectorTrie + +open Graphs + +open I8051 + +open Order + +open Registers + +open CostLabel + +open Hide + +open Proper + +open PositiveMap + +open Deqsets + +open ErrorMessages + +open PreIdentifiers + +open Errors + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open Div_and_mod + +open Jmeq + +open Russell + +open List + +open Util + +open FoldStuff + +open BitVector + +open Types + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +open Z + +open BitVectorZ + +open Pointers + +open ByteValues + +open BackEndOps + +open Joint + +open ERTL + +val examine_internal : + AST.ident List.list -> Joint.joint_internal_function -> Positive.pos + Identifiers.identifier_map + diff --git a/extracted/util.ml b/extracted/util.ml new file mode 100644 index 0000000..491e7db --- /dev/null +++ b/extracted/util.ml @@ -0,0 +1,667 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Jmeq + +open Russell + +type dAEMONXXX = +| K1DAEMONXXX +| K2DAEMONXXX + +(** val dAEMONXXX_rect_Type4 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 **) +let rec dAEMONXXX_rect_Type4 h_K1DAEMONXXX h_K2DAEMONXXX = function +| K1DAEMONXXX -> h_K1DAEMONXXX +| K2DAEMONXXX -> h_K2DAEMONXXX + +(** val dAEMONXXX_rect_Type5 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 **) +let rec dAEMONXXX_rect_Type5 h_K1DAEMONXXX h_K2DAEMONXXX = function +| K1DAEMONXXX -> h_K1DAEMONXXX +| K2DAEMONXXX -> h_K2DAEMONXXX + +(** val dAEMONXXX_rect_Type3 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 **) +let rec dAEMONXXX_rect_Type3 h_K1DAEMONXXX h_K2DAEMONXXX = function +| K1DAEMONXXX -> h_K1DAEMONXXX +| K2DAEMONXXX -> h_K2DAEMONXXX + +(** val dAEMONXXX_rect_Type2 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 **) +let rec dAEMONXXX_rect_Type2 h_K1DAEMONXXX h_K2DAEMONXXX = function +| K1DAEMONXXX -> h_K1DAEMONXXX +| K2DAEMONXXX -> h_K2DAEMONXXX + +(** val dAEMONXXX_rect_Type1 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 **) +let rec dAEMONXXX_rect_Type1 h_K1DAEMONXXX h_K2DAEMONXXX = function +| K1DAEMONXXX -> h_K1DAEMONXXX +| K2DAEMONXXX -> h_K2DAEMONXXX + +(** val dAEMONXXX_rect_Type0 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 **) +let rec dAEMONXXX_rect_Type0 h_K1DAEMONXXX h_K2DAEMONXXX = function +| K1DAEMONXXX -> h_K1DAEMONXXX +| K2DAEMONXXX -> h_K2DAEMONXXX + +(** val dAEMONXXX_inv_rect_Type4 : + dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let dAEMONXXX_inv_rect_Type4 hterm h1 h2 = + let hcut = dAEMONXXX_rect_Type4 h1 h2 hterm in hcut __ + +(** val dAEMONXXX_inv_rect_Type3 : + dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let dAEMONXXX_inv_rect_Type3 hterm h1 h2 = + let hcut = dAEMONXXX_rect_Type3 h1 h2 hterm in hcut __ + +(** val dAEMONXXX_inv_rect_Type2 : + dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let dAEMONXXX_inv_rect_Type2 hterm h1 h2 = + let hcut = dAEMONXXX_rect_Type2 h1 h2 hterm in hcut __ + +(** val dAEMONXXX_inv_rect_Type1 : + dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let dAEMONXXX_inv_rect_Type1 hterm h1 h2 = + let hcut = dAEMONXXX_rect_Type1 h1 h2 hterm in hcut __ + +(** val dAEMONXXX_inv_rect_Type0 : + dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let dAEMONXXX_inv_rect_Type0 hterm h1 h2 = + let hcut = dAEMONXXX_rect_Type0 h1 h2 hterm in hcut __ + +(** val dAEMONXXX_discr : dAEMONXXX -> dAEMONXXX -> __ **) +let dAEMONXXX_discr x y = + Logic.eq_rect_Type2 x + (match x with + | K1DAEMONXXX -> Obj.magic (fun _ dH -> dH) + | K2DAEMONXXX -> Obj.magic (fun _ dH -> dH)) y + +(** val dAEMONXXX_jmdiscr : dAEMONXXX -> dAEMONXXX -> __ **) +let dAEMONXXX_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | K1DAEMONXXX -> Obj.magic (fun _ dH -> dH) + | K2DAEMONXXX -> Obj.magic (fun _ dH -> dH)) y + +(** val ltb : Nat.nat -> Nat.nat -> Bool.bool **) +let ltb m n = + Nat.leb (Nat.S m) n + +(** val geb : Nat.nat -> Nat.nat -> Bool.bool **) +let geb m n = + Nat.leb n m + +(** val gtb : Nat.nat -> Nat.nat -> Bool.bool **) +let gtb m n = + ltb n m + +(** val eq_nat : Nat.nat -> Nat.nat -> Bool.bool **) +let rec eq_nat n m = + match n with + | Nat.O -> + (match m with + | Nat.O -> Bool.True + | Nat.S x -> Bool.False) + | Nat.S n' -> + (match m with + | Nat.O -> Bool.False + | Nat.S m' -> eq_nat n' m') + +(** val forall : ('a1 -> Bool.bool) -> 'a1 List.list -> Bool.bool **) +let rec forall f = function +| List.Nil -> Bool.True +| List.Cons (hd, tl) -> Bool.andb (f hd) (forall f tl) + +(** val prefix : Nat.nat -> 'a1 List.list -> 'a1 List.list **) +let rec prefix k = function +| List.Nil -> List.Nil +| List.Cons (hd, tl) -> + (match k with + | Nat.O -> List.Nil + | Nat.S k' -> List.Cons (hd, (prefix k' tl))) + +(** val fold_left2 : + ('a1 -> 'a2 -> 'a3 -> 'a1) -> 'a1 -> 'a2 List.list -> 'a3 List.list -> + 'a1 **) +let rec fold_left2 f accu left right = + (match left with + | List.Nil -> + (fun _ -> + (match right with + | List.Nil -> (fun _ -> accu) + | List.Cons (hd, tl) -> + (fun _ -> + Obj.magic Nat.nat_discr Nat.O (Nat.S (List.length tl)) __)) __) + | List.Cons (hd, tl) -> + (fun _ -> + (match right with + | List.Nil -> + (fun _ -> + Obj.magic Nat.nat_discr (Nat.S (List.length tl)) Nat.O __) + | List.Cons (hd', tl') -> + (fun _ -> fold_left2 f (f accu hd hd') tl tl')) __)) __ + +(** val remove_n_first_internal : + Nat.nat -> 'a1 List.list -> Nat.nat -> 'a1 List.list **) +let rec remove_n_first_internal i l n = + match l with + | List.Nil -> List.Nil + | List.Cons (hd, tl) -> + (match eq_nat i n with + | Bool.True -> l + | Bool.False -> remove_n_first_internal (Nat.S i) tl n) + +(** val remove_n_first : Nat.nat -> 'a1 List.list -> 'a1 List.list **) +let remove_n_first n l = + remove_n_first_internal Nat.O l n + +(** val foldi_from_until_internal : + Nat.nat -> 'a1 List.list -> 'a1 List.list -> Nat.nat -> (Nat.nat -> 'a1 + List.list -> 'a1 -> 'a1 List.list) -> 'a1 List.list **) +let rec foldi_from_until_internal i res rem m f = + match rem with + | List.Nil -> res + | List.Cons (e, tl) -> + (match geb i m with + | Bool.True -> res + | Bool.False -> foldi_from_until_internal (Nat.S i) (f i res e) tl m f) + +(** val foldi_from_until : + Nat.nat -> Nat.nat -> (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) + -> 'a1 List.list -> 'a1 List.list -> 'a1 List.list **) +let foldi_from_until n m f a l = + foldi_from_until_internal Nat.O a (remove_n_first n l) m f + +(** val foldi_from : + Nat.nat -> (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) -> 'a1 + List.list -> 'a1 List.list -> 'a1 List.list **) +let foldi_from n f a l = + foldi_from_until n (List.length l) f a l + +(** val foldi_until : + Nat.nat -> (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) -> 'a1 + List.list -> 'a1 List.list -> 'a1 List.list **) +let foldi_until m f a l = + foldi_from_until Nat.O m f a l + +(** val foldi : + (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) -> 'a1 List.list -> + 'a1 List.list -> 'a1 List.list **) +let foldi f a l = + foldi_from_until Nat.O (List.length l) f a l + +(** val hd_safe : 'a1 List.list -> 'a1 **) +let hd_safe l = + (match l with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (hd, tl) -> (fun _ -> hd)) __ + +(** val tail_safe : 'a1 List.list -> 'a1 List.list **) +let tail_safe l = + (match l with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (hd, tl) -> (fun _ -> tl)) __ + +(** val safe_split : + 'a1 List.list -> Nat.nat -> ('a1 List.list, 'a1 List.list) Types.prod **) +let rec safe_split l index = + (match index with + | Nat.O -> (fun _ -> { Types.fst = List.Nil; Types.snd = l }) + | Nat.S index' -> + (fun _ -> + (match l with + | List.Nil -> (fun _ -> assert false (* absurd case *)) + | List.Cons (hd, tl) -> + (fun _ -> + let { Types.fst = l1; Types.snd = l2 } = safe_split tl index' in + { Types.fst = (List.Cons (hd, l1)); Types.snd = l2 })) __)) __ + +(** val nth_safe : Nat.nat -> 'a1 List.list -> 'a1 **) +let rec nth_safe index the_list = + (match index with + | Nat.O -> + (match the_list with + | List.Nil -> (fun _ -> Logic.false_rect_Type0 __) + | List.Cons (hd, tl) -> (fun _ -> hd)) + | Nat.S index' -> + (match the_list with + | List.Nil -> (fun _ -> Logic.false_rect_Type0 __) + | List.Cons (hd, tl) -> (fun _ -> nth_safe index' tl))) __ + +(** val last_safe : 'a1 List.list -> 'a1 **) +let last_safe the_list = + nth_safe (Nat.minus (List.length the_list) (Nat.S Nat.O)) the_list + +(** val reduce : + 'a1 List.list -> 'a2 List.list -> (('a1 List.list, 'a1 List.list) + Types.prod, ('a2 List.list, 'a2 List.list) Types.prod) Types.prod **) +let rec reduce left right = + match left with + | List.Nil -> + { Types.fst = { Types.fst = List.Nil; Types.snd = List.Nil }; Types.snd = + { Types.fst = List.Nil; Types.snd = right } } + | List.Cons (hd, tl) -> + (match right with + | List.Nil -> + { Types.fst = { Types.fst = List.Nil; Types.snd = left }; Types.snd = + { Types.fst = List.Nil; Types.snd = List.Nil } } + | List.Cons (hd', tl') -> + let { Types.fst = cleft; Types.snd = cright } = reduce tl tl' in + let { Types.fst = commonl; Types.snd = restl } = cleft in + let { Types.fst = commonr; Types.snd = restr } = cright in + { Types.fst = { Types.fst = (List.Cons (hd, commonl)); Types.snd = + restl }; Types.snd = { Types.fst = (List.Cons (hd', commonr)); + Types.snd = restr } }) + +(** val reduce_strong : + 'a1 List.list -> 'a2 List.list -> (('a1 List.list, 'a1 List.list) + Types.prod, ('a2 List.list, 'a2 List.list) Types.prod) Types.prod + Types.sig0 **) +let rec reduce_strong left right = + (match left with + | List.Nil -> + (fun _ -> { Types.fst = { Types.fst = List.Nil; Types.snd = List.Nil }; + Types.snd = { Types.fst = List.Nil; Types.snd = right } }) + | List.Cons (hd, tl) -> + (fun _ -> + (match right with + | List.Nil -> + (fun _ -> { Types.fst = { Types.fst = List.Nil; Types.snd = left }; + Types.snd = { Types.fst = List.Nil; Types.snd = List.Nil } }) + | List.Cons (hd', tl') -> + (fun _ -> + (let { Types.fst = cleft; Types.snd = cright } = + Types.pi1 (reduce_strong tl tl') + in + (fun _ -> + (let { Types.fst = commonl; Types.snd = restl } = cleft in + (fun _ -> + (let { Types.fst = commonr; Types.snd = restr } = cright in + (fun _ -> { Types.fst = { Types.fst = (List.Cons (hd, commonl)); + Types.snd = restl }; Types.snd = { Types.fst = (List.Cons (hd', + commonr)); Types.snd = restr } })) __)) __)) __)) __)) __ + +(** val map2_opt : + ('a1 -> 'a2 -> 'a3) -> 'a1 List.list -> 'a2 List.list -> 'a3 List.list + Types.option **) +let rec map2_opt f left right = + match left with + | List.Nil -> + (match right with + | List.Nil -> Types.Some List.Nil + | List.Cons (x, x0) -> Types.None) + | List.Cons (hd, tl) -> + (match right with + | List.Nil -> Types.None + | List.Cons (hd', tl') -> + (match map2_opt f tl tl' with + | Types.None -> Types.None + | Types.Some tail -> Types.Some (List.Cons ((f hd hd'), tail)))) + +(** val map2 : + ('a1 -> 'a2 -> 'a3) -> 'a1 List.list -> 'a2 List.list -> 'a3 List.list **) +let rec map2 f left right = + (match left with + | List.Nil -> + (match right with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (x, x0) -> + (fun _ -> Obj.magic Nat.nat_discr Nat.O (Nat.S (List.length x0)) __)) + | List.Cons (hd, tl) -> + (match right with + | List.Nil -> + (fun _ -> Obj.magic Nat.nat_discr (Nat.S (List.length tl)) Nat.O __) + | List.Cons (hd', tl') -> + (fun _ -> List.Cons ((f hd hd'), (map2 f tl tl'))))) __ + +(** val map3 : + ('a1 -> 'a2 -> 'a3 -> 'a4) -> 'a1 List.list -> 'a2 List.list -> 'a3 + List.list -> 'a4 List.list **) +let rec map3 f left centre right = + (match left with + | List.Nil -> + (fun _ -> + (match centre with + | List.Nil -> + (fun _ -> + (match right with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (hd, tl) -> + (fun _ -> + Obj.magic Nat.nat_discr Nat.O (Nat.S (List.length tl)) __)) + __) + | List.Cons (hd, tl) -> + (fun _ -> + Logic.eq_rect_Type0 (List.length centre) + (Logic.eq_rect_Type0 (List.length List.Nil) (fun _ -> + Obj.magic Nat.nat_discr (Nat.S (List.length tl)) Nat.O __) + (List.length centre)) (List.length right) __)) __) + | List.Cons (hd, tl) -> + (fun _ -> + (match centre with + | List.Nil -> + (fun _ -> + Logic.eq_rect_Type0 (List.length centre) + (Logic.eq_rect_Type0 (List.length (List.Cons (hd, tl))) + (fun _ -> + Obj.magic Nat.nat_discr Nat.O (Nat.S (List.length tl)) __) + (List.length centre)) (List.length right) __) + | List.Cons (hd', tl') -> + (fun _ -> + (match right with + | List.Nil -> + (fun _ _ -> + Obj.magic Nat.nat_discr (Nat.S (List.length tl')) Nat.O __) + | List.Cons (hd'', tl'') -> + (fun _ _ -> List.Cons ((f hd hd' hd''), (map3 f tl tl' tl'')))) + __ __)) __)) __ + +(** val eq_rect_Type0_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type0_r a h x = + (fun _ auto -> auto) __ h + +(** val safe_nth : Nat.nat -> 'a1 List.list -> 'a1 **) +let rec safe_nth n l = + (match n with + | Nat.O -> + (match l with + | List.Nil -> (fun _ -> Logic.false_rect_Type0 __) + | List.Cons (hd, tl) -> (fun _ -> hd)) + | Nat.S n' -> + (match l with + | List.Nil -> (fun _ -> Logic.false_rect_Type0 __) + | List.Cons (hd, tl) -> (fun _ -> safe_nth n' tl))) __ + +(** val nub_by_internal : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat -> 'a1 List.list **) +let rec nub_by_internal f l = function +| Nat.O -> + (match l with + | List.Nil -> List.Nil + | List.Cons (hd, tl) -> l) +| Nat.S n0 -> + (match l with + | List.Nil -> List.Nil + | List.Cons (hd, tl) -> + List.Cons (hd, + (nub_by_internal f (List.filter (fun y -> Bool.notb (f y hd)) tl) n0))) + +(** val nub_by : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 List.list -> 'a1 List.list **) +let nub_by f l = + nub_by_internal f l (List.length l) + +(** val member : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 -> 'a1 List.list -> Bool.bool **) +let rec member eq a = function +| List.Nil -> Bool.False +| List.Cons (hd, tl) -> Bool.orb (eq a hd) (member eq a tl) + +(** val take : Nat.nat -> 'a1 List.list -> 'a1 List.list **) +let rec take n l = + match n with + | Nat.O -> List.Nil + | Nat.S n0 -> + (match l with + | List.Nil -> List.Nil + | List.Cons (hd, tl) -> List.Cons (hd, (take n0 tl))) + +(** val drop : Nat.nat -> 'a1 List.list -> 'a1 List.list **) +let rec drop n l = + match n with + | Nat.O -> l + | Nat.S n0 -> + (match l with + | List.Nil -> List.Nil + | List.Cons (hd, tl) -> drop n0 tl) + +(** val list_split : + Nat.nat -> 'a1 List.list -> ('a1 List.list, 'a1 List.list) Types.prod **) +let list_split n l = + { Types.fst = (take n l); Types.snd = (drop n l) } + +(** val mapi_internal : + Nat.nat -> (Nat.nat -> 'a1 -> 'a2) -> 'a1 List.list -> 'a2 List.list **) +let rec mapi_internal n f = function +| List.Nil -> List.Nil +| List.Cons (hd, tl) -> + List.Cons ((f n hd), (mapi_internal (Nat.plus n (Nat.S Nat.O)) f tl)) + +(** val mapi : (Nat.nat -> 'a1 -> 'a2) -> 'a1 List.list -> 'a2 List.list **) +let mapi f l = + mapi_internal Nat.O f l + +(** val zip_pottier : + 'a1 List.list -> 'a2 List.list -> ('a1, 'a2) Types.prod List.list **) +let rec zip_pottier left right = + match left with + | List.Nil -> List.Nil + | List.Cons (hd, tl) -> + (match right with + | List.Nil -> List.Nil + | List.Cons (hd', tl') -> + List.Cons ({ Types.fst = hd; Types.snd = hd' }, (zip_pottier tl tl'))) + +(** val zip_safe : + 'a1 List.list -> 'a2 List.list -> ('a1, 'a2) Types.prod List.list **) +let rec zip_safe left right = + (match left with + | List.Nil -> + (fun _ -> + (match right with + | List.Nil -> (fun _ -> List.Nil) + | List.Cons (hd, tl) -> + (fun _ -> + Obj.magic Nat.nat_discr Nat.O (Nat.S (List.length tl)) __)) __) + | List.Cons (hd, tl) -> + (fun _ -> + (match right with + | List.Nil -> + (fun _ -> + Obj.magic Nat.nat_discr (Nat.S (List.length tl)) Nat.O __) + | List.Cons (hd', tl') -> + (fun _ -> List.Cons ({ Types.fst = hd; Types.snd = hd' }, + (zip_safe tl tl')))) __)) __ + +(** val zip : + 'a1 List.list -> 'a2 List.list -> ('a1, 'a2) Types.prod List.list + Types.option **) +let rec zip l r = + match l with + | List.Nil -> Types.Some List.Nil + | List.Cons (hd, tl) -> + (match r with + | List.Nil -> Types.None + | List.Cons (hd', tl') -> + (match zip tl tl' with + | Types.None -> Types.None + | Types.Some tail -> + Types.Some (List.Cons ({ Types.fst = hd; Types.snd = hd' }, tail)))) + +(** val foldl : ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 List.list -> 'a1 **) +let rec foldl f a = function +| List.Nil -> a +| List.Cons (hd, tl) -> foldl f (f a hd) tl + +(** val rev : 'a1 List.list -> 'a1 List.list **) +let rev l = + List.reverse l + +(** val fold_left_i_aux : + (Nat.nat -> 'a1 -> 'a2 -> 'a1) -> 'a1 -> Nat.nat -> 'a2 List.list -> 'a1 **) +let rec fold_left_i_aux f x i = function +| List.Nil -> x +| List.Cons (hd, tl) -> fold_left_i_aux f (f i x hd) (Nat.S i) tl + +(** val fold_left_i : + (Nat.nat -> 'a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 List.list -> 'a1 **) +let fold_left_i f x = + fold_left_i_aux f x Nat.O + +(** val function_apply : ('a1 -> 'a2) -> 'a1 -> 'a2 **) +let function_apply f a = + f a + +(** val iterate : ('a1 -> 'a1) -> 'a1 -> Nat.nat -> 'a1 **) +let rec iterate f a = function +| Nat.O -> a +| Nat.S o -> f (iterate f a o) + +(** val division_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat **) +let rec division_aux m n p = + match ltb n (Nat.S p) with + | Bool.True -> Nat.O + | Bool.False -> + (match m with + | Nat.O -> Nat.O + | Nat.S q -> Nat.S (division_aux q (Nat.minus n (Nat.S p)) p)) + +(** val division : Nat.nat -> Nat.nat -> Nat.nat **) +let division m = function +| Nat.O -> Nat.S m +| Nat.S o -> division_aux m m o + +(** val modulus_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat **) +let rec modulus_aux m n p = + match Nat.leb n p with + | Bool.True -> n + | Bool.False -> + (match m with + | Nat.O -> n + | Nat.S o -> modulus_aux o (Nat.minus n (Nat.S p)) p) + +(** val modulus : Nat.nat -> Nat.nat -> Nat.nat **) +let modulus m = function +| Nat.O -> m +| Nat.S o -> modulus_aux m m o + +(** val divide_with_remainder : + Nat.nat -> Nat.nat -> (Nat.nat, Nat.nat) Types.prod **) +let divide_with_remainder m n = + { Types.fst = (division m n); Types.snd = (modulus m n) } + +(** val less_than_or_equal_b_elim : + Nat.nat -> Nat.nat -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let less_than_or_equal_b_elim m n h1 h2 = + (match Nat.leb m n with + | Bool.True -> (fun _ _ -> h1 __) + | Bool.False -> (fun _ _ -> h2 __)) __ __ + +open Div_and_mod + +(** val dpi1__o__bool_to_Prop__o__inject : + (Bool.bool, 'a1) Types.dPair -> __ Types.sig0 **) +let dpi1__o__bool_to_Prop__o__inject x2 = + __ + +(** val eject__o__bool_to_Prop__o__inject : + Bool.bool Types.sig0 -> __ Types.sig0 **) +let eject__o__bool_to_Prop__o__inject x2 = + __ + +(** val bool_to_Prop__o__inject : Bool.bool -> __ Types.sig0 **) +let bool_to_Prop__o__inject x1 = + __ + +(** val dpi1__o__bool_to_Prop_to_eq__o__inject : + Bool.bool -> (__, 'a1) Types.dPair -> __ Types.sig0 **) +let dpi1__o__bool_to_Prop_to_eq__o__inject x0 x3 = + __ + +(** val eject__o__bool_to_Prop_to_eq__o__inject : + Bool.bool -> __ Types.sig0 -> __ Types.sig0 **) +let eject__o__bool_to_Prop_to_eq__o__inject x0 x3 = + __ + +(** val bool_to_Prop_to_eq__o__inject : Bool.bool -> __ Types.sig0 **) +let bool_to_Prop_to_eq__o__inject x0 = + __ + +(** val dpi1__o__not_bool_to_Prop_to_eq__o__inject : + Bool.bool -> (__, 'a1) Types.dPair -> __ Types.sig0 **) +let dpi1__o__not_bool_to_Prop_to_eq__o__inject x0 x3 = + __ + +(** val eject__o__not_bool_to_Prop_to_eq__o__inject : + Bool.bool -> __ Types.sig0 -> __ Types.sig0 **) +let eject__o__not_bool_to_Prop_to_eq__o__inject x0 x3 = + __ + +(** val not_bool_to_Prop_to_eq__o__inject : Bool.bool -> __ Types.sig0 **) +let not_bool_to_Prop_to_eq__o__inject x0 = + __ + +(** val if_then_else_safe : + Bool.bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let if_then_else_safe b f g = + (match b with + | Bool.True -> f + | Bool.False -> g) __ + +(** val dpi1__o__not_neq_None__o__inject : + 'a1 Types.option -> (__, 'a2) Types.dPair -> __ Types.sig0 **) +let dpi1__o__not_neq_None__o__inject x1 x4 = + __ + +(** val eject__o__not_neq_None__o__inject : + 'a1 Types.option -> __ Types.sig0 -> __ Types.sig0 **) +let eject__o__not_neq_None__o__inject x1 x4 = + __ + +(** val not_neq_None__o__inject : 'a1 Types.option -> __ Types.sig0 **) +let not_neq_None__o__inject x1 = + __ + +(** val prod_jmdiscr : + ('a1, 'a2) Types.prod -> ('a1, 'a2) Types.prod -> __ **) +let prod_jmdiscr x y = + Logic.eq_rect_Type2 x + (let { Types.fst = a0; Types.snd = a10 } = x in + Obj.magic (fun _ dH -> dH __ __)) y + +(** val eq_rect_Type1_r : 'a1 -> 'a2 -> 'a1 -> 'a2 **) +let eq_rect_Type1_r a h x = + (fun _ auto -> auto) __ h + +(** val some_Some_elim : 'a1 -> 'a1 -> (__ -> 'a2) -> 'a2 **) +let some_Some_elim x y h = + h __ + +(** val pose : 'a1 -> ('a1 -> __ -> 'a2) -> 'a2 **) +let pose a auto = + auto a __ + +(** val eq_sum : + ('a1 -> 'a1 -> Bool.bool) -> ('a2 -> 'a2 -> Bool.bool) -> ('a1, 'a2) + Types.sum -> ('a1, 'a2) Types.sum -> Bool.bool **) +let eq_sum leq req left right = + match left with + | Types.Inl l -> + (match right with + | Types.Inl l' -> leq l l' + | Types.Inr x -> Bool.False) + | Types.Inr r -> + (match right with + | Types.Inl x -> Bool.False + | Types.Inr r' -> req r r') + +(** val eq_prod : + ('a1 -> 'a1 -> Bool.bool) -> ('a2 -> 'a2 -> Bool.bool) -> ('a1, 'a2) + Types.prod -> ('a1, 'a2) Types.prod -> Bool.bool **) +let eq_prod leq req left right = + let { Types.fst = l; Types.snd = r } = left in + let { Types.fst = l'; Types.snd = r' } = right in + Bool.andb (leq l l') (req r r') + diff --git a/extracted/util.mli b/extracted/util.mli new file mode 100644 index 0000000..059bb3b --- /dev/null +++ b/extracted/util.mli @@ -0,0 +1,237 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Jmeq + +open Russell + +type dAEMONXXX = +| K1DAEMONXXX +| K2DAEMONXXX + +val dAEMONXXX_rect_Type4 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 + +val dAEMONXXX_rect_Type5 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 + +val dAEMONXXX_rect_Type3 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 + +val dAEMONXXX_rect_Type2 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 + +val dAEMONXXX_rect_Type1 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 + +val dAEMONXXX_rect_Type0 : 'a1 -> 'a1 -> dAEMONXXX -> 'a1 + +val dAEMONXXX_inv_rect_Type4 : dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val dAEMONXXX_inv_rect_Type3 : dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val dAEMONXXX_inv_rect_Type2 : dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val dAEMONXXX_inv_rect_Type1 : dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val dAEMONXXX_inv_rect_Type0 : dAEMONXXX -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val dAEMONXXX_discr : dAEMONXXX -> dAEMONXXX -> __ + +val dAEMONXXX_jmdiscr : dAEMONXXX -> dAEMONXXX -> __ + +val ltb : Nat.nat -> Nat.nat -> Bool.bool + +val geb : Nat.nat -> Nat.nat -> Bool.bool + +val gtb : Nat.nat -> Nat.nat -> Bool.bool + +val eq_nat : Nat.nat -> Nat.nat -> Bool.bool + +val forall : ('a1 -> Bool.bool) -> 'a1 List.list -> Bool.bool + +val prefix : Nat.nat -> 'a1 List.list -> 'a1 List.list + +val fold_left2 : + ('a1 -> 'a2 -> 'a3 -> 'a1) -> 'a1 -> 'a2 List.list -> 'a3 List.list -> 'a1 + +val remove_n_first_internal : + Nat.nat -> 'a1 List.list -> Nat.nat -> 'a1 List.list + +val remove_n_first : Nat.nat -> 'a1 List.list -> 'a1 List.list + +val foldi_from_until_internal : + Nat.nat -> 'a1 List.list -> 'a1 List.list -> Nat.nat -> (Nat.nat -> 'a1 + List.list -> 'a1 -> 'a1 List.list) -> 'a1 List.list + +val foldi_from_until : + Nat.nat -> Nat.nat -> (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) -> + 'a1 List.list -> 'a1 List.list -> 'a1 List.list + +val foldi_from : + Nat.nat -> (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) -> 'a1 + List.list -> 'a1 List.list -> 'a1 List.list + +val foldi_until : + Nat.nat -> (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) -> 'a1 + List.list -> 'a1 List.list -> 'a1 List.list + +val foldi : + (Nat.nat -> 'a1 List.list -> 'a1 -> 'a1 List.list) -> 'a1 List.list -> 'a1 + List.list -> 'a1 List.list + +val hd_safe : 'a1 List.list -> 'a1 + +val tail_safe : 'a1 List.list -> 'a1 List.list + +val safe_split : + 'a1 List.list -> Nat.nat -> ('a1 List.list, 'a1 List.list) Types.prod + +val nth_safe : Nat.nat -> 'a1 List.list -> 'a1 + +val last_safe : 'a1 List.list -> 'a1 + +val reduce : + 'a1 List.list -> 'a2 List.list -> (('a1 List.list, 'a1 List.list) + Types.prod, ('a2 List.list, 'a2 List.list) Types.prod) Types.prod + +val reduce_strong : + 'a1 List.list -> 'a2 List.list -> (('a1 List.list, 'a1 List.list) + Types.prod, ('a2 List.list, 'a2 List.list) Types.prod) Types.prod + Types.sig0 + +val map2_opt : + ('a1 -> 'a2 -> 'a3) -> 'a1 List.list -> 'a2 List.list -> 'a3 List.list + Types.option + +val map2 : + ('a1 -> 'a2 -> 'a3) -> 'a1 List.list -> 'a2 List.list -> 'a3 List.list + +val map3 : + ('a1 -> 'a2 -> 'a3 -> 'a4) -> 'a1 List.list -> 'a2 List.list -> 'a3 + List.list -> 'a4 List.list + +val eq_rect_Type0_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val safe_nth : Nat.nat -> 'a1 List.list -> 'a1 + +val nub_by_internal : + ('a1 -> 'a1 -> Bool.bool) -> 'a1 List.list -> Nat.nat -> 'a1 List.list + +val nub_by : ('a1 -> 'a1 -> Bool.bool) -> 'a1 List.list -> 'a1 List.list + +val member : ('a1 -> 'a1 -> Bool.bool) -> 'a1 -> 'a1 List.list -> Bool.bool + +val take : Nat.nat -> 'a1 List.list -> 'a1 List.list + +val drop : Nat.nat -> 'a1 List.list -> 'a1 List.list + +val list_split : + Nat.nat -> 'a1 List.list -> ('a1 List.list, 'a1 List.list) Types.prod + +val mapi_internal : + Nat.nat -> (Nat.nat -> 'a1 -> 'a2) -> 'a1 List.list -> 'a2 List.list + +val mapi : (Nat.nat -> 'a1 -> 'a2) -> 'a1 List.list -> 'a2 List.list + +val zip_pottier : + 'a1 List.list -> 'a2 List.list -> ('a1, 'a2) Types.prod List.list + +val zip_safe : + 'a1 List.list -> 'a2 List.list -> ('a1, 'a2) Types.prod List.list + +val zip : + 'a1 List.list -> 'a2 List.list -> ('a1, 'a2) Types.prod List.list + Types.option + +val foldl : ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 List.list -> 'a1 + +val rev : 'a1 List.list -> 'a1 List.list + +val fold_left_i_aux : + (Nat.nat -> 'a1 -> 'a2 -> 'a1) -> 'a1 -> Nat.nat -> 'a2 List.list -> 'a1 + +val fold_left_i : + (Nat.nat -> 'a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 List.list -> 'a1 + +val function_apply : ('a1 -> 'a2) -> 'a1 -> 'a2 + +val iterate : ('a1 -> 'a1) -> 'a1 -> Nat.nat -> 'a1 + +val division_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat + +val division : Nat.nat -> Nat.nat -> Nat.nat + +val modulus_aux : Nat.nat -> Nat.nat -> Nat.nat -> Nat.nat + +val modulus : Nat.nat -> Nat.nat -> Nat.nat + +val divide_with_remainder : + Nat.nat -> Nat.nat -> (Nat.nat, Nat.nat) Types.prod + +val less_than_or_equal_b_elim : + Nat.nat -> Nat.nat -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +open Div_and_mod + +val dpi1__o__bool_to_Prop__o__inject : + (Bool.bool, 'a1) Types.dPair -> __ Types.sig0 + +val eject__o__bool_to_Prop__o__inject : Bool.bool Types.sig0 -> __ Types.sig0 + +val bool_to_Prop__o__inject : Bool.bool -> __ Types.sig0 + +val dpi1__o__bool_to_Prop_to_eq__o__inject : + Bool.bool -> (__, 'a1) Types.dPair -> __ Types.sig0 + +val eject__o__bool_to_Prop_to_eq__o__inject : + Bool.bool -> __ Types.sig0 -> __ Types.sig0 + +val bool_to_Prop_to_eq__o__inject : Bool.bool -> __ Types.sig0 + +val dpi1__o__not_bool_to_Prop_to_eq__o__inject : + Bool.bool -> (__, 'a1) Types.dPair -> __ Types.sig0 + +val eject__o__not_bool_to_Prop_to_eq__o__inject : + Bool.bool -> __ Types.sig0 -> __ Types.sig0 + +val not_bool_to_Prop_to_eq__o__inject : Bool.bool -> __ Types.sig0 + +val if_then_else_safe : Bool.bool -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val dpi1__o__not_neq_None__o__inject : + 'a1 Types.option -> (__, 'a2) Types.dPair -> __ Types.sig0 + +val eject__o__not_neq_None__o__inject : + 'a1 Types.option -> __ Types.sig0 -> __ Types.sig0 + +val not_neq_None__o__inject : 'a1 Types.option -> __ Types.sig0 + +val prod_jmdiscr : ('a1, 'a2) Types.prod -> ('a1, 'a2) Types.prod -> __ + +val eq_rect_Type1_r : 'a1 -> 'a2 -> 'a1 -> 'a2 + +val some_Some_elim : 'a1 -> 'a1 -> (__ -> 'a2) -> 'a2 + +val pose : 'a1 -> ('a1 -> __ -> 'a2) -> 'a2 + +val eq_sum : + ('a1 -> 'a1 -> Bool.bool) -> ('a2 -> 'a2 -> Bool.bool) -> ('a1, 'a2) + Types.sum -> ('a1, 'a2) Types.sum -> Bool.bool + +val eq_prod : + ('a1 -> 'a1 -> Bool.bool) -> ('a2 -> 'a2 -> Bool.bool) -> ('a1, 'a2) + Types.prod -> ('a1, 'a2) Types.prod -> Bool.bool + diff --git a/extracted/utilBranch.ml b/extracted/utilBranch.ml new file mode 100644 index 0000000..99b5db2 --- /dev/null +++ b/extracted/utilBranch.ml @@ -0,0 +1,51 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Arithmetic + +(** val nat_of_bool : Bool.bool -> Nat.nat **) +let nat_of_bool = function +| Bool.True -> Nat.S Nat.O +| Bool.False -> Nat.O + diff --git a/extracted/utilBranch.mli b/extracted/utilBranch.mli new file mode 100644 index 0000000..37fdc58 --- /dev/null +++ b/extracted/utilBranch.mli @@ -0,0 +1,48 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Util + +open Exp + +open Setoids + +open Monad + +open Option + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Arithmetic + +val nat_of_bool : Bool.bool -> Nat.nat + diff --git a/extracted/values.ml b/extracted/values.ml new file mode 100644 index 0000000..5a3b570 --- /dev/null +++ b/extracted/values.ml @@ -0,0 +1,528 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +type val0 = +| Vundef +| Vint of AST.intsize * AST.bvint +| Vnull +| Vptr of Pointers.pointer + +(** val val_rect_Type4 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 **) +let rec val_rect_Type4 h_Vundef h_Vint h_Vnull h_Vptr = function +| Vundef -> h_Vundef +| Vint (sz, x_5112) -> h_Vint sz x_5112 +| Vnull -> h_Vnull +| Vptr x_5113 -> h_Vptr x_5113 + +(** val val_rect_Type5 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 **) +let rec val_rect_Type5 h_Vundef h_Vint h_Vnull h_Vptr = function +| Vundef -> h_Vundef +| Vint (sz, x_5119) -> h_Vint sz x_5119 +| Vnull -> h_Vnull +| Vptr x_5120 -> h_Vptr x_5120 + +(** val val_rect_Type3 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 **) +let rec val_rect_Type3 h_Vundef h_Vint h_Vnull h_Vptr = function +| Vundef -> h_Vundef +| Vint (sz, x_5126) -> h_Vint sz x_5126 +| Vnull -> h_Vnull +| Vptr x_5127 -> h_Vptr x_5127 + +(** val val_rect_Type2 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 **) +let rec val_rect_Type2 h_Vundef h_Vint h_Vnull h_Vptr = function +| Vundef -> h_Vundef +| Vint (sz, x_5133) -> h_Vint sz x_5133 +| Vnull -> h_Vnull +| Vptr x_5134 -> h_Vptr x_5134 + +(** val val_rect_Type1 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 **) +let rec val_rect_Type1 h_Vundef h_Vint h_Vnull h_Vptr = function +| Vundef -> h_Vundef +| Vint (sz, x_5140) -> h_Vint sz x_5140 +| Vnull -> h_Vnull +| Vptr x_5141 -> h_Vptr x_5141 + +(** val val_rect_Type0 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 **) +let rec val_rect_Type0 h_Vundef h_Vint h_Vnull h_Vptr = function +| Vundef -> h_Vundef +| Vint (sz, x_5147) -> h_Vint sz x_5147 +| Vnull -> h_Vnull +| Vptr x_5148 -> h_Vptr x_5148 + +(** val val_inv_rect_Type4 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 **) +let val_inv_rect_Type4 hterm h1 h2 h3 h4 = + let hcut = val_rect_Type4 h1 h2 h3 h4 hterm in hcut __ + +(** val val_inv_rect_Type3 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 **) +let val_inv_rect_Type3 hterm h1 h2 h3 h4 = + let hcut = val_rect_Type3 h1 h2 h3 h4 hterm in hcut __ + +(** val val_inv_rect_Type2 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 **) +let val_inv_rect_Type2 hterm h1 h2 h3 h4 = + let hcut = val_rect_Type2 h1 h2 h3 h4 hterm in hcut __ + +(** val val_inv_rect_Type1 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 **) +let val_inv_rect_Type1 hterm h1 h2 h3 h4 = + let hcut = val_rect_Type1 h1 h2 h3 h4 hterm in hcut __ + +(** val val_inv_rect_Type0 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 **) +let val_inv_rect_Type0 hterm h1 h2 h3 h4 = + let hcut = val_rect_Type0 h1 h2 h3 h4 hterm in hcut __ + +(** val val_discr : val0 -> val0 -> __ **) +let val_discr x y = + Logic.eq_rect_Type2 x + (match x with + | Vundef -> Obj.magic (fun _ dH -> dH) + | Vint (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Vnull -> Obj.magic (fun _ dH -> dH) + | Vptr a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val val_jmdiscr : val0 -> val0 -> __ **) +let val_jmdiscr x y = + Logic.eq_rect_Type2 x + (match x with + | Vundef -> Obj.magic (fun _ dH -> dH) + | Vint (a0, a1) -> Obj.magic (fun _ dH -> dH __ __) + | Vnull -> Obj.magic (fun _ dH -> dH) + | Vptr a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val vzero : AST.intsize -> val0 **) +let vzero sz = + Vint (sz, (BitVector.zero (AST.bitsize_of_intsize sz))) + +(** val vone : AST.intsize -> val0 **) +let vone sz = + Vint (sz, (AST.repr sz (Nat.S Nat.O))) + +(** val mone : AST.intsize -> BitVector.bitVector **) +let mone sz = + BitVectorZ.bitvector_of_Z (AST.bitsize_of_intsize sz) (Z.Neg Positive.One) + +(** val vmone : AST.intsize -> val0 **) +let vmone sz = + Vint (sz, (mone sz)) + +(** val vtrue : val0 **) +let vtrue = + vone AST.I32 + +(** val vfalse : val0 **) +let vfalse = + vzero AST.I32 + +(** val of_bool : Bool.bool -> val0 **) +let of_bool = function +| Bool.True -> vtrue +| Bool.False -> vfalse + +(** val eval_bool_of_val : val0 -> Bool.bool Errors.res **) +let eval_bool_of_val = function +| Vundef -> Errors.Error (Errors.msg ErrorMessages.ValueNotABoolean) +| Vint (x, i) -> + Errors.OK + (Bool.notb + (BitVector.eq_bv (AST.bitsize_of_intsize x) i + (BitVector.zero (AST.bitsize_of_intsize x)))) +| Vnull -> Errors.OK Bool.False +| Vptr x -> Errors.OK Bool.True + +(** val neg : val0 -> val0 **) +let neg = function +| Vundef -> Vundef +| Vint (sz, n) -> + Vint (sz, + (Arithmetic.two_complement_negation (AST.bitsize_of_intsize sz) n)) +| Vnull -> Vundef +| Vptr x -> Vundef + +(** val notint : val0 -> val0 **) +let notint = function +| Vundef -> Vundef +| Vint (sz, n) -> + Vint (sz, + (BitVector.exclusive_disjunction_bv (AST.bitsize_of_intsize sz) n + (mone sz))) +| Vnull -> Vundef +| Vptr x -> Vundef + +(** val notbool : val0 -> val0 **) +let notbool = function +| Vundef -> Vundef +| Vint (sz, n) -> + of_bool + (BitVector.eq_bv (AST.bitsize_of_intsize sz) n + (BitVector.zero (AST.bitsize_of_intsize sz))) +| Vnull -> vtrue +| Vptr x -> vfalse + +(** val zero_ext : AST.intsize -> val0 -> val0 **) +let zero_ext rsz = function +| Vundef -> Vundef +| Vint (sz, n) -> + Vint (rsz, + (Arithmetic.zero_ext (AST.bitsize_of_intsize sz) + (AST.bitsize_of_intsize rsz) n)) +| Vnull -> Vundef +| Vptr x -> Vundef + +(** val sign_ext : AST.intsize -> val0 -> val0 **) +let sign_ext rsz = function +| Vundef -> Vundef +| Vint (sz, i) -> + Vint (rsz, + (Arithmetic.sign_ext (AST.bitsize_of_intsize sz) + (AST.bitsize_of_intsize rsz) i)) +| Vnull -> Vundef +| Vptr x -> Vundef + +(** val add : val0 -> val0 -> val0 **) +let add v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Vint (sz2, + (Arithmetic.addition_n (AST.bitsize_of_intsize sz2) n10 n2))) Vundef + | Vnull -> Vundef + | Vptr ptr -> + Vptr (Pointers.shift_pointer (AST.bitsize_of_intsize sz1) ptr n1)) + | Vnull -> Vundef + | Vptr ptr -> + (match v2 with + | Vundef -> Vundef + | Vint (x, n2) -> + Vptr (Pointers.shift_pointer (AST.bitsize_of_intsize x) ptr n2) + | Vnull -> Vundef + | Vptr x -> Vundef) + +(** val sub : val0 -> val0 -> val0 **) +let sub v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Vint (sz2, + (Arithmetic.subtraction (AST.bitsize_of_intsize sz2) n10 n2))) + Vundef + | Vnull -> Vundef + | Vptr x -> Vundef) + | Vnull -> + (match v2 with + | Vundef -> Vundef + | Vint (x, x0) -> Vundef + | Vnull -> vzero AST.I32 + | Vptr x -> Vundef) + | Vptr ptr1 -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + Vptr (Pointers.neg_shift_pointer (AST.bitsize_of_intsize sz2) ptr1 n2) + | Vnull -> Vundef + | Vptr ptr2 -> + (match Pointers.eq_block ptr1.Pointers.pblock ptr2.Pointers.pblock with + | Bool.True -> + Vint (AST.I32, + (Pointers.sub_offset (AST.bitsize_of_intsize AST.I32) + ptr1.Pointers.poff ptr2.Pointers.poff)) + | Bool.False -> Vundef)) + +(** val mul : val0 -> val0 -> val0 **) +let mul v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Vint (sz2, + (Vector.vsplit (AST.bitsize_of_intsize sz2) + (AST.bitsize_of_intsize sz2) + (Arithmetic.multiplication (AST.bitsize_of_intsize sz2) n10 n2)).Types.snd)) + Vundef + | Vnull -> Vundef + | Vptr x -> Vundef) + | Vnull -> Vundef + | Vptr x -> Vundef + +(** val v_and : val0 -> val0 -> val0 **) +let v_and v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Vint (sz2, + (BitVector.conjunction_bv (AST.bitsize_of_intsize sz2) n10 n2))) + Vundef + | Vnull -> Vundef + | Vptr x -> Vundef) + | Vnull -> Vundef + | Vptr x -> Vundef + +(** val or0 : val0 -> val0 -> val0 **) +let or0 v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Vint (sz2, + (BitVector.inclusive_disjunction_bv (AST.bitsize_of_intsize sz2) n10 + n2))) Vundef + | Vnull -> Vundef + | Vptr x -> Vundef) + | Vnull -> Vundef + | Vptr x -> Vundef + +(** val xor : val0 -> val0 -> val0 **) +let xor v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> Vint (sz2, + (BitVector.exclusive_disjunction_bv (AST.bitsize_of_intsize sz2) n10 + n2))) Vundef + | Vnull -> Vundef + | Vptr x -> Vundef) + | Vnull -> Vundef + | Vptr x -> Vundef + +(** val cmp_match : Integers.comparison -> val0 **) +let cmp_match = function +| Integers.Ceq -> vtrue +| Integers.Cne -> vfalse +| Integers.Clt -> Vundef +| Integers.Cle -> Vundef +| Integers.Cgt -> Vundef +| Integers.Cge -> Vundef + +(** val cmp_mismatch : Integers.comparison -> val0 **) +let cmp_mismatch = function +| Integers.Ceq -> vfalse +| Integers.Cne -> vtrue +| Integers.Clt -> Vundef +| Integers.Cle -> Vundef +| Integers.Cgt -> Vundef +| Integers.Cge -> Vundef + +(** val cmp_offset : + Integers.comparison -> Pointers.offset -> Pointers.offset -> Bool.bool **) +let cmp_offset c x y = + match c with + | Integers.Ceq -> Pointers.eq_offset x y + | Integers.Cne -> Bool.notb (Pointers.eq_offset x y) + | Integers.Clt -> Pointers.lt_offset x y + | Integers.Cle -> Bool.notb (Pointers.lt_offset y x) + | Integers.Cgt -> Pointers.lt_offset y x + | Integers.Cge -> Bool.notb (Pointers.lt_offset x y) + +(** val cmp_int : + Nat.nat -> Integers.comparison -> BitVector.bitVector -> + BitVector.bitVector -> Bool.bool **) +let cmp_int n c x y = + match c with + | Integers.Ceq -> BitVector.eq_bv n x y + | Integers.Cne -> Bool.notb (BitVector.eq_bv n x y) + | Integers.Clt -> Arithmetic.lt_s n x y + | Integers.Cle -> Bool.notb (Arithmetic.lt_s n y x) + | Integers.Cgt -> Arithmetic.lt_s n y x + | Integers.Cge -> Bool.notb (Arithmetic.lt_s n x y) + +(** val cmpu_int : + Nat.nat -> Integers.comparison -> BitVector.bitVector -> + BitVector.bitVector -> Bool.bool **) +let cmpu_int n c x y = + match c with + | Integers.Ceq -> BitVector.eq_bv n x y + | Integers.Cne -> Bool.notb (BitVector.eq_bv n x y) + | Integers.Clt -> Arithmetic.lt_u n x y + | Integers.Cle -> Bool.notb (Arithmetic.lt_u n y x) + | Integers.Cgt -> Arithmetic.lt_u n y x + | Integers.Cge -> Bool.notb (Arithmetic.lt_u n x y) + +(** val cmp : Integers.comparison -> val0 -> val0 -> val0 **) +let cmp c v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + of_bool (cmp_int (AST.bitsize_of_intsize sz2) c n10 n2)) Vundef + | Vnull -> Vundef + | Vptr x -> Vundef) + | Vnull -> + (match v2 with + | Vundef -> Vundef + | Vint (x, x0) -> Vundef + | Vnull -> cmp_match c + | Vptr x -> cmp_mismatch c) + | Vptr ptr1 -> + (match v2 with + | Vundef -> Vundef + | Vint (x, x0) -> Vundef + | Vnull -> cmp_mismatch c + | Vptr ptr2 -> + (match Pointers.eq_block ptr1.Pointers.pblock ptr2.Pointers.pblock with + | Bool.True -> + of_bool (cmp_offset c ptr1.Pointers.poff ptr2.Pointers.poff) + | Bool.False -> cmp_mismatch c)) + +(** val cmpu : Integers.comparison -> val0 -> val0 -> val0 **) +let cmpu c v1 v2 = + match v1 with + | Vundef -> Vundef + | Vint (sz1, n1) -> + (match v2 with + | Vundef -> Vundef + | Vint (sz2, n2) -> + AST.intsize_eq_elim sz1 sz2 n1 (fun n10 -> + of_bool (cmpu_int (AST.bitsize_of_intsize sz2) c n10 n2)) Vundef + | Vnull -> Vundef + | Vptr x -> Vundef) + | Vnull -> + (match v2 with + | Vundef -> Vundef + | Vint (x, x0) -> Vundef + | Vnull -> cmp_match c + | Vptr x -> cmp_mismatch c) + | Vptr ptr1 -> + (match v2 with + | Vundef -> Vundef + | Vint (x, x0) -> Vundef + | Vnull -> cmp_mismatch c + | Vptr ptr2 -> + (match Pointers.eq_block ptr1.Pointers.pblock ptr2.Pointers.pblock with + | Bool.True -> + of_bool (cmp_offset c ptr1.Pointers.poff ptr2.Pointers.poff) + | Bool.False -> cmp_mismatch c)) + +(** val load_result : AST.typ -> val0 -> val0 **) +let rec load_result chunk v = match v with +| Vundef -> Vundef +| Vint (sz, n) -> + (match chunk with + | AST.ASTint (sz', sg) -> + (match AST.eq_intsize sz sz' with + | Bool.True -> v + | Bool.False -> Vundef) + | AST.ASTptr -> Vundef) +| Vnull -> + (match chunk with + | AST.ASTint (x, x0) -> Vundef + | AST.ASTptr -> Vnull) +| Vptr ptr -> + (match chunk with + | AST.ASTint (x, x0) -> Vundef + | AST.ASTptr -> Vptr ptr) + diff --git a/extracted/values.mli b/extracted/values.mli new file mode 100644 index 0000000..8c65945 --- /dev/null +++ b/extracted/values.mli @@ -0,0 +1,193 @@ +open Preamble + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Bool + +open Relations + +open Nat + +open List + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open Coqlib + +open ErrorMessages + +open Option + +open Setoids + +open Monad + +open Positive + +open PreIdentifiers + +open Errors + +open Proper + +open PositiveMap + +open Deqsets + +open Extralib + +open Lists + +open Identifiers + +open Integers + +open AST + +open Division + +open Exp + +open Arithmetic + +open Extranat + +open Vector + +open FoldStuff + +open BitVector + +open Z + +open BitVectorZ + +open Pointers + +type val0 = +| Vundef +| Vint of AST.intsize * AST.bvint +| Vnull +| Vptr of Pointers.pointer + +val val_rect_Type4 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 + +val val_rect_Type5 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 + +val val_rect_Type3 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 + +val val_rect_Type2 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 + +val val_rect_Type1 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 + +val val_rect_Type0 : + 'a1 -> (AST.intsize -> AST.bvint -> 'a1) -> 'a1 -> (Pointers.pointer -> + 'a1) -> val0 -> 'a1 + +val val_inv_rect_Type4 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 + +val val_inv_rect_Type3 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 + +val val_inv_rect_Type2 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 + +val val_inv_rect_Type1 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 + +val val_inv_rect_Type0 : + val0 -> (__ -> 'a1) -> (AST.intsize -> AST.bvint -> __ -> 'a1) -> (__ -> + 'a1) -> (Pointers.pointer -> __ -> 'a1) -> 'a1 + +val val_discr : val0 -> val0 -> __ + +val val_jmdiscr : val0 -> val0 -> __ + +val vzero : AST.intsize -> val0 + +val vone : AST.intsize -> val0 + +val mone : AST.intsize -> BitVector.bitVector + +val vmone : AST.intsize -> val0 + +val vtrue : val0 + +val vfalse : val0 + +val of_bool : Bool.bool -> val0 + +val eval_bool_of_val : val0 -> Bool.bool Errors.res + +val neg : val0 -> val0 + +val notint : val0 -> val0 + +val notbool : val0 -> val0 + +val zero_ext : AST.intsize -> val0 -> val0 + +val sign_ext : AST.intsize -> val0 -> val0 + +val add : val0 -> val0 -> val0 + +val sub : val0 -> val0 -> val0 + +val mul : val0 -> val0 -> val0 + +val v_and : val0 -> val0 -> val0 + +val or0 : val0 -> val0 -> val0 + +val xor : val0 -> val0 -> val0 + +val cmp_match : Integers.comparison -> val0 + +val cmp_mismatch : Integers.comparison -> val0 + +val cmp_offset : + Integers.comparison -> Pointers.offset -> Pointers.offset -> Bool.bool + +val cmp_int : + Nat.nat -> Integers.comparison -> BitVector.bitVector -> + BitVector.bitVector -> Bool.bool + +val cmpu_int : + Nat.nat -> Integers.comparison -> BitVector.bitVector -> + BitVector.bitVector -> Bool.bool + +val cmp : Integers.comparison -> val0 -> val0 -> val0 + +val cmpu : Integers.comparison -> val0 -> val0 -> val0 + +val load_result : AST.typ -> val0 -> val0 + diff --git a/extracted/vector.ml b/extracted/vector.ml new file mode 100644 index 0000000..ecd4426 --- /dev/null +++ b/extracted/vector.ml @@ -0,0 +1,477 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Setoids + +open Monad + +open Option + +open Extranat + +type 'a vector = +| VEmpty +| VCons of Nat.nat * 'a * 'a vector + +(** val vector_rect_Type4 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 **) +let rec vector_rect_Type4 h_VEmpty h_VCons x_1293 = function +| VEmpty -> h_VEmpty +| VCons (n, x_1296, x_1295) -> + h_VCons n x_1296 x_1295 (vector_rect_Type4 h_VEmpty h_VCons n x_1295) + +(** val vector_rect_Type3 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 **) +let rec vector_rect_Type3 h_VEmpty h_VCons x_1305 = function +| VEmpty -> h_VEmpty +| VCons (n, x_1308, x_1307) -> + h_VCons n x_1308 x_1307 (vector_rect_Type3 h_VEmpty h_VCons n x_1307) + +(** val vector_rect_Type2 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 **) +let rec vector_rect_Type2 h_VEmpty h_VCons x_1311 = function +| VEmpty -> h_VEmpty +| VCons (n, x_1314, x_1313) -> + h_VCons n x_1314 x_1313 (vector_rect_Type2 h_VEmpty h_VCons n x_1313) + +(** val vector_rect_Type1 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 **) +let rec vector_rect_Type1 h_VEmpty h_VCons x_1317 = function +| VEmpty -> h_VEmpty +| VCons (n, x_1320, x_1319) -> + h_VCons n x_1320 x_1319 (vector_rect_Type1 h_VEmpty h_VCons n x_1319) + +(** val vector_rect_Type0 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 **) +let rec vector_rect_Type0 h_VEmpty h_VCons x_1323 = function +| VEmpty -> h_VEmpty +| VCons (n, x_1326, x_1325) -> + h_VCons n x_1326 x_1325 (vector_rect_Type0 h_VEmpty h_VCons n x_1325) + +(** val vector_inv_rect_Type4 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 + vector -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 **) +let vector_inv_rect_Type4 x2 hterm h1 h2 = + let hcut = vector_rect_Type4 h1 h2 x2 hterm in hcut __ __ + +(** val vector_inv_rect_Type3 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 + vector -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 **) +let vector_inv_rect_Type3 x2 hterm h1 h2 = + let hcut = vector_rect_Type3 h1 h2 x2 hterm in hcut __ __ + +(** val vector_inv_rect_Type2 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 + vector -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 **) +let vector_inv_rect_Type2 x2 hterm h1 h2 = + let hcut = vector_rect_Type2 h1 h2 x2 hterm in hcut __ __ + +(** val vector_inv_rect_Type1 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 + vector -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 **) +let vector_inv_rect_Type1 x2 hterm h1 h2 = + let hcut = vector_rect_Type1 h1 h2 x2 hterm in hcut __ __ + +(** val vector_inv_rect_Type0 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 + vector -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 **) +let vector_inv_rect_Type0 x2 hterm h1 h2 = + let hcut = vector_rect_Type0 h1 h2 x2 hterm in hcut __ __ + +(** val vector_discr : Nat.nat -> 'a1 vector -> 'a1 vector -> __ **) +let vector_discr a2 x y = + Logic.eq_rect_Type2 x + (match x with + | VEmpty -> Obj.magic (fun _ dH -> dH) + | VCons (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val vector_jmdiscr : Nat.nat -> 'a1 vector -> 'a1 vector -> __ **) +let vector_jmdiscr a2 x y = + Logic.eq_rect_Type2 x + (match x with + | VEmpty -> Obj.magic (fun _ dH -> dH) + | VCons (a0, a10, a20) -> Obj.magic (fun _ dH -> dH __ __ __)) y + +(** val get_index_v : Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 **) +let rec get_index_v n v m = + (match m with + | Nat.O -> + (match v with + | VEmpty -> (fun _ -> assert false (* absurd case *)) + | VCons (p, hd, tl) -> (fun _ -> hd)) + | Nat.S o -> + (match v with + | VEmpty -> (fun _ -> assert false (* absurd case *)) + | VCons (p, hd, tl) -> (fun _ -> get_index_v p tl o))) __ + +(** val get_index' : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 **) +let get_index' n m b = + get_index_v (Nat.S (Nat.plus n m)) b n + +(** val get_index_weak_v : + Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 Types.option **) +let rec get_index_weak_v n v = function +| Nat.O -> + (match v with + | VEmpty -> Types.None + | VCons (p, hd, tl) -> Types.Some hd) +| Nat.S o -> + (match v with + | VEmpty -> Types.None + | VCons (p, hd, tl) -> get_index_weak_v p tl o) + +(** val set_index : Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 -> 'a1 vector **) +let rec set_index n v m a = + (match m with + | Nat.O -> + (match v with + | VEmpty -> (fun _ -> VEmpty) + | VCons (p, hd, tl) -> (fun _ -> VCons (p, a, tl))) + | Nat.S o -> + (match v with + | VEmpty -> (fun _ -> VEmpty) + | VCons (p, hd, tl) -> (fun _ -> VCons (p, hd, (set_index p tl o a))))) + __ + +(** val set_index_weak : + Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 -> 'a1 vector Types.option **) +let rec set_index_weak n v m a = + match m with + | Nat.O -> + (match v with + | VEmpty -> Types.None + | VCons (o, hd, tl) -> Types.Some v) + | Nat.S o -> + (match v with + | VEmpty -> Types.None + | VCons (p, hd, tl) -> + let settail = set_index_weak p tl o a in + (match settail with + | Types.None -> Types.None + | Types.Some j -> Types.Some v)) + +(** val drop : + Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 vector Types.option **) +let rec drop n v = function +| Nat.O -> Types.Some v +| Nat.S o -> + (match v with + | VEmpty -> Types.None + | VCons (p, hd, tl) -> Types.None) + +(** val head' : Nat.nat -> 'a1 vector -> 'a1 **) +let head' n = function +| VEmpty -> Obj.magic __ +| VCons (x, hd, x0) -> hd + +(** val tail : Nat.nat -> 'a1 vector -> 'a1 vector **) +let tail n = function +| VEmpty -> Obj.magic __ +| VCons (m, hd, tl) -> tl + +(** val vsplit' : + Nat.nat -> Nat.nat -> 'a1 vector -> ('a1 vector, 'a1 vector) Types.prod **) +let rec vsplit' m n = + match m with + | Nat.O -> (fun v -> { Types.fst = VEmpty; Types.snd = v }) + | Nat.S m' -> + (fun v -> + let { Types.fst = l; Types.snd = r } = + vsplit' m' n (tail (Nat.plus m' n) v) + in + { Types.fst = (VCons (m', (head' (Nat.plus m' n) v), l)); Types.snd = + r }) + +(** val vsplit : + Nat.nat -> Nat.nat -> 'a1 vector -> ('a1 vector, 'a1 vector) Types.prod **) +let rec vsplit m n v = + vsplit' m n v + +(** val head : Nat.nat -> 'a1 vector -> ('a1, 'a1 vector) Types.prod **) +let head n v = + (match v with + | VEmpty -> (fun _ -> assert false (* absurd case *)) + | VCons (o, he, tl) -> (fun _ -> { Types.fst = he; Types.snd = tl })) __ + +(** val from_singl : 'a1 vector -> 'a1 **) +let from_singl v = + (head Nat.O v).Types.fst + +(** val fold_right : + Nat.nat -> ('a1 -> 'a2 -> 'a2) -> 'a2 -> 'a1 vector -> 'a2 **) +let rec fold_right n f x = function +| VEmpty -> x +| VCons (n0, hd, tl) -> f hd (fold_right n0 f x tl) + +(** val fold_right_i : + Nat.nat -> (Nat.nat -> 'a1 -> 'a2 -> 'a2) -> 'a2 -> 'a1 vector -> 'a2 **) +let rec fold_right_i n f x = function +| VEmpty -> x +| VCons (n0, hd, tl) -> f n0 hd (fold_right_i n0 f x tl) + +(** val fold_right2_i : + (Nat.nat -> 'a1 -> 'a2 -> 'a3 -> 'a3) -> 'a3 -> Nat.nat -> 'a1 vector -> + 'a2 vector -> 'a3 **) +let rec fold_right2_i f c n v q = + (match v with + | VEmpty -> + (match q with + | VEmpty -> (fun _ -> c) + | VCons (o, hd, tl) -> (fun _ -> assert false (* absurd case *))) + | VCons (o, hd, tl) -> + (match q with + | VEmpty -> (fun _ -> assert false (* absurd case *)) + | VCons (p, hd', tl') -> + (fun _ -> f o hd hd' (fold_right2_i f c o tl tl')))) __ + +(** val fold_left : + Nat.nat -> ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 vector -> 'a1 **) +let rec fold_left n f x = function +| VEmpty -> x +| VCons (n0, hd, tl) -> fold_left n0 f (f x hd) tl + +(** val map : Nat.nat -> ('a1 -> 'a2) -> 'a1 vector -> 'a2 vector **) +let rec map n f = function +| VEmpty -> VEmpty +| VCons (n0, hd, tl) -> VCons (n0, (f hd), (map n0 f tl)) + +(** val zip_with : + Nat.nat -> ('a1 -> 'a2 -> 'a3) -> 'a1 vector -> 'a2 vector -> 'a3 vector **) +let rec zip_with n f v q = + (match v with + | VEmpty -> (fun _ -> VEmpty) + | VCons (n0, hd, tl) -> + (match q with + | VEmpty -> (fun _ -> Obj.magic Nat.nat_discr (Nat.S n0) Nat.O __) + | VCons (m, hd', tl') -> + (fun _ -> VCons (n0, (f hd hd'), + (zip_with n0 f tl (Util.eq_rect_Type0_r m tl' n0)))))) __ + +(** val zip : + Nat.nat -> 'a1 vector -> 'a2 vector -> ('a1, 'a2) Types.prod vector **) +let zip n v q = + zip_with n (fun x x0 -> { Types.fst = x; Types.snd = x0 }) v q + +(** val replicate : Nat.nat -> 'a1 -> 'a1 vector **) +let rec replicate n h = + match n with + | Nat.O -> VEmpty + | Nat.S m -> VCons (m, h, (replicate m h)) + +(** val append : + Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector -> 'a1 vector **) +let rec append n m v q = + match v with + | VEmpty -> q + | VCons (o, hd, tl) -> VCons ((Nat.plus o m), hd, (append o m tl q)) + +(** val scan_left : + Nat.nat -> ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 vector -> 'a1 vector **) +let rec scan_left n f a v = + VCons (n, a, + (match v with + | VEmpty -> VEmpty + | VCons (o, hd, tl) -> scan_left o f (f a hd) tl)) + +(** val scan_right : + Nat.nat -> ('a1 -> 'a2 -> 'a1) -> 'a2 -> 'a1 vector -> 'a1 List.list **) +let rec scan_right n f b = function +| VEmpty -> List.Nil +| VCons (o, hd, tl) -> List.Cons ((f hd b), (scan_right o f b tl)) + +(** val revapp : + Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector -> 'a1 vector **) +let rec revapp n m v acc = + match v with + | VEmpty -> acc + | VCons (o, hd, tl) -> revapp o (Nat.S m) tl (VCons (m, hd, acc)) + +(** val reverse : Nat.nat -> 'a1 vector -> 'a1 vector **) +let rec reverse n v = + revapp n Nat.O v VEmpty + +(** val pad_vector : + 'a1 -> Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector **) +let rec pad_vector a n m v = + match n with + | Nat.O -> v + | Nat.S n' -> VCons ((Nat.plus n' m), a, (pad_vector a n' m v)) + +(** val list_of_vector : Nat.nat -> 'a1 vector -> 'a1 List.list **) +let rec list_of_vector n = function +| VEmpty -> List.Nil +| VCons (o, hd, tl) -> List.Cons (hd, (list_of_vector o tl)) + +(** val vector_of_list : 'a1 List.list -> 'a1 vector **) +let rec vector_of_list = function +| List.Nil -> VEmpty +| List.Cons (hd, tl) -> VCons ((List.length tl), hd, (vector_of_list tl)) + +(** val rotate_left : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector **) +let rec rotate_left n m v = + match m with + | Nat.O -> v + | Nat.S o -> + (match v with + | VEmpty -> VEmpty + | VCons (p, hd, tl) -> + rotate_left (Nat.S p) o + (append p (Nat.S Nat.O) tl (VCons (Nat.O, hd, VEmpty)))) + +(** val rotate_right : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector **) +let rotate_right n m v = + reverse n (rotate_left n m (reverse n v)) + +(** val shift_left_1 : Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector **) +let shift_left_1 n v a = + (match v with + | VEmpty -> (fun _ -> assert false (* absurd case *)) + | VCons (o, hd, tl) -> + (fun _ -> reverse (Nat.S o) (VCons (o, a, (reverse o tl))))) __ + +(** val switch_bv_plus : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector **) +let switch_bv_plus n m i = + i + +(** val shift_right_1 : Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector **) +let shift_right_1 n v a = + let { Types.fst = v'; Types.snd = dropped } = + vsplit n (Nat.S Nat.O) (switch_bv_plus (Nat.S Nat.O) n v) + in + VCons (n, a, v') + +(** val shift_left : + Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector **) +let shift_left n m = + match Extranat.nat_compare n m with + | Extranat.Nat_lt (x, x0) -> (fun v a -> replicate x a) + | Extranat.Nat_eq x -> (fun v a -> replicate x a) + | Extranat.Nat_gt (d, m0) -> + (fun v a -> + let { Types.fst = v0; Types.snd = v' } = vsplit m0 (Nat.S d) v in + switch_bv_plus (Nat.S d) m0 (append (Nat.S d) m0 v' (replicate m0 a))) + +(** val shift_right : + Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector **) +let shift_right n m v a = + Util.iterate (fun x -> shift_right_1 n x a) v m + +(** val eq_v : + Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 vector -> + Bool.bool **) +let rec eq_v n f b c = + (match b with + | VEmpty -> + (fun c0 -> + match c0 with + | VEmpty -> Bool.True + | VCons (x, x0, x1) -> Obj.magic __ x x0 x1) + | VCons (m, hd, tl) -> + (fun c0 -> Bool.andb (f hd (head' m c0)) (eq_v m f tl (tail m c0)))) c + +(** val vector_inv_n : Nat.nat -> 'a1 vector -> __ **) +let vector_inv_n n v = + (match v with + | VEmpty -> (fun _ -> Obj.magic (fun auto -> auto)) + | VCons (n0, auto, auto') -> + (fun _ -> Obj.magic (fun auto'' -> auto'' auto auto'))) __ + +(** val eq_v_elim : + ('a2 -> 'a2 -> Bool.bool) -> (__ -> 'a2 -> 'a2 -> (__ -> __) -> (__ -> + __) -> __) -> Nat.nat -> 'a2 vector -> 'a2 vector -> (__ -> 'a1) -> (__ + -> 'a1) -> 'a1 **) +let eq_v_elim f f_elim n x = + vector_rect_Type0 (fun y -> + Obj.magic vector_inv_n Nat.O y (fun auto auto' -> auto __)) + (fun m h t iH y -> + Obj.magic vector_inv_n (Nat.S m) y (fun h' t' ht hf -> + Obj.magic f_elim __ h h' (fun _ -> + iH (tail m (VCons (m, h', t'))) (fun _ -> ht __) (fun _ -> hf __)) + (fun _ -> hf __))) n x + +(** val mem : + ('a1 -> 'a1 -> Bool.bool) -> Nat.nat -> 'a1 vector -> 'a1 -> Bool.bool **) +let mem eq_a n l x = + fold_right n (fun y v -> Bool.orb (eq_a x y) v) Bool.False l + +(** val subvector_with : + Nat.nat -> Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 + vector -> Bool.bool **) +let rec subvector_with n m eq sub sup = + match sub with + | VEmpty -> Bool.True + | VCons (n', hd, tl) -> + (match mem eq m sup hd with + | Bool.True -> subvector_with n' m eq tl sup + | Bool.False -> Bool.False) + +(** val vprefix : + Nat.nat -> Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 + vector -> Bool.bool **) +let rec vprefix n m test v1 v2 = + match v1 with + | VEmpty -> Bool.True + | VCons (n', hd1, tl1) -> + (match v2 with + | VEmpty -> Bool.False + | VCons (m', hd2, tl2) -> + Bool.andb (test hd1 hd2) (vprefix n' m' test tl1 tl2)) + +(** val vsuffix : + Nat.nat -> Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 + vector -> Bool.bool **) +let rec vsuffix n m test v1 v2 = + Util.if_then_else_safe (Nat.leb (Nat.S n) m) (fun _ -> + (match v2 with + | VEmpty -> (fun _ -> assert false (* absurd case *)) + | VCons (m', hd2, tl2) -> (fun _ -> vsuffix n m' test v1 tl2)) __) + (fun _ -> + match Nat.eqb n m with + | Bool.True -> vprefix n m test v1 v2 + | Bool.False -> Bool.False) + +(** val rvsplit : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector vector **) +let rec rvsplit n m = + match n with + | Nat.O -> (fun x -> VEmpty) + | Nat.S k -> + (fun v -> + let { Types.fst = pre; Types.snd = post } = vsplit m (Nat.times k m) v + in + VCons (k, pre, (rvsplit k m post))) + +(** val vflatten : Nat.nat -> Nat.nat -> 'a1 vector vector -> 'a1 vector **) +let rec vflatten n m = function +| VEmpty -> VEmpty +| VCons (n', hd, tl) -> append m (Nat.times n' m) hd (vflatten n' m tl) + diff --git a/extracted/vector.mli b/extracted/vector.mli new file mode 100644 index 0000000..eb625e5 --- /dev/null +++ b/extracted/vector.mli @@ -0,0 +1,193 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Types + +open List + +open Div_and_mod + +open Jmeq + +open Russell + +open Util + +open Setoids + +open Monad + +open Option + +open Extranat + +type 'a vector = +| VEmpty +| VCons of Nat.nat * 'a * 'a vector + +val vector_rect_Type4 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 + +val vector_rect_Type3 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 + +val vector_rect_Type2 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 + +val vector_rect_Type1 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 + +val vector_rect_Type0 : + 'a2 -> (Nat.nat -> 'a1 -> 'a1 vector -> 'a2 -> 'a2) -> Nat.nat -> 'a1 + vector -> 'a2 + +val vector_inv_rect_Type4 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 vector + -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 + +val vector_inv_rect_Type3 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 vector + -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 + +val vector_inv_rect_Type2 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 vector + -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 + +val vector_inv_rect_Type1 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 vector + -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 + +val vector_inv_rect_Type0 : + Nat.nat -> 'a1 vector -> (__ -> __ -> 'a2) -> (Nat.nat -> 'a1 -> 'a1 vector + -> (__ -> __ -> 'a2) -> __ -> __ -> 'a2) -> 'a2 + +val vector_discr : Nat.nat -> 'a1 vector -> 'a1 vector -> __ + +val vector_jmdiscr : Nat.nat -> 'a1 vector -> 'a1 vector -> __ + +val get_index_v : Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 + +val get_index' : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 + +val get_index_weak_v : Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 Types.option + +val set_index : Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 -> 'a1 vector + +val set_index_weak : + Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 -> 'a1 vector Types.option + +val drop : Nat.nat -> 'a1 vector -> Nat.nat -> 'a1 vector Types.option + +val head' : Nat.nat -> 'a1 vector -> 'a1 + +val tail : Nat.nat -> 'a1 vector -> 'a1 vector + +val vsplit' : + Nat.nat -> Nat.nat -> 'a1 vector -> ('a1 vector, 'a1 vector) Types.prod + +val vsplit : + Nat.nat -> Nat.nat -> 'a1 vector -> ('a1 vector, 'a1 vector) Types.prod + +val head : Nat.nat -> 'a1 vector -> ('a1, 'a1 vector) Types.prod + +val from_singl : 'a1 vector -> 'a1 + +val fold_right : Nat.nat -> ('a1 -> 'a2 -> 'a2) -> 'a2 -> 'a1 vector -> 'a2 + +val fold_right_i : + Nat.nat -> (Nat.nat -> 'a1 -> 'a2 -> 'a2) -> 'a2 -> 'a1 vector -> 'a2 + +val fold_right2_i : + (Nat.nat -> 'a1 -> 'a2 -> 'a3 -> 'a3) -> 'a3 -> Nat.nat -> 'a1 vector -> + 'a2 vector -> 'a3 + +val fold_left : Nat.nat -> ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 vector -> 'a1 + +val map : Nat.nat -> ('a1 -> 'a2) -> 'a1 vector -> 'a2 vector + +val zip_with : + Nat.nat -> ('a1 -> 'a2 -> 'a3) -> 'a1 vector -> 'a2 vector -> 'a3 vector + +val zip : Nat.nat -> 'a1 vector -> 'a2 vector -> ('a1, 'a2) Types.prod vector + +val replicate : Nat.nat -> 'a1 -> 'a1 vector + +val append : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector -> 'a1 vector + +val scan_left : + Nat.nat -> ('a1 -> 'a2 -> 'a1) -> 'a1 -> 'a2 vector -> 'a1 vector + +val scan_right : + Nat.nat -> ('a1 -> 'a2 -> 'a1) -> 'a2 -> 'a1 vector -> 'a1 List.list + +val revapp : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector -> 'a1 vector + +val reverse : Nat.nat -> 'a1 vector -> 'a1 vector + +val pad_vector : 'a1 -> Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector + +val list_of_vector : Nat.nat -> 'a1 vector -> 'a1 List.list + +val vector_of_list : 'a1 List.list -> 'a1 vector + +val rotate_left : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector + +val rotate_right : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector + +val shift_left_1 : Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector + +val switch_bv_plus : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector + +val shift_right_1 : Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector + +val shift_left : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector + +val shift_right : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 -> 'a1 vector + +val eq_v : + Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 vector -> + Bool.bool + +val vector_inv_n : Nat.nat -> 'a1 vector -> __ + +val eq_v_elim : + ('a2 -> 'a2 -> Bool.bool) -> (__ -> 'a2 -> 'a2 -> (__ -> __) -> (__ -> __) + -> __) -> Nat.nat -> 'a2 vector -> 'a2 vector -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 + +val mem : + ('a1 -> 'a1 -> Bool.bool) -> Nat.nat -> 'a1 vector -> 'a1 -> Bool.bool + +val subvector_with : + Nat.nat -> Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 vector + -> Bool.bool + +val vprefix : + Nat.nat -> Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 vector + -> Bool.bool + +val vsuffix : + Nat.nat -> Nat.nat -> ('a1 -> 'a1 -> Bool.bool) -> 'a1 vector -> 'a1 vector + -> Bool.bool + +val rvsplit : Nat.nat -> Nat.nat -> 'a1 vector -> 'a1 vector vector + +val vflatten : Nat.nat -> Nat.nat -> 'a1 vector vector -> 'a1 vector + diff --git a/extracted/z.ml b/extracted/z.ml new file mode 100644 index 0000000..5634982 --- /dev/null +++ b/extracted/z.ml @@ -0,0 +1,306 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +type z = +| OZ +| Pos of Positive.pos +| Neg of Positive.pos + +(** val z_rect_Type4 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 **) +let rec z_rect_Type4 h_OZ h_pos h_neg = function +| OZ -> h_OZ +| Pos x_4786 -> h_pos x_4786 +| Neg x_4787 -> h_neg x_4787 + +(** val z_rect_Type5 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 **) +let rec z_rect_Type5 h_OZ h_pos h_neg = function +| OZ -> h_OZ +| Pos x_4792 -> h_pos x_4792 +| Neg x_4793 -> h_neg x_4793 + +(** val z_rect_Type3 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 **) +let rec z_rect_Type3 h_OZ h_pos h_neg = function +| OZ -> h_OZ +| Pos x_4798 -> h_pos x_4798 +| Neg x_4799 -> h_neg x_4799 + +(** val z_rect_Type2 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 **) +let rec z_rect_Type2 h_OZ h_pos h_neg = function +| OZ -> h_OZ +| Pos x_4804 -> h_pos x_4804 +| Neg x_4805 -> h_neg x_4805 + +(** val z_rect_Type1 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 **) +let rec z_rect_Type1 h_OZ h_pos h_neg = function +| OZ -> h_OZ +| Pos x_4810 -> h_pos x_4810 +| Neg x_4811 -> h_neg x_4811 + +(** val z_rect_Type0 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 **) +let rec z_rect_Type0 h_OZ h_pos h_neg = function +| OZ -> h_OZ +| Pos x_4816 -> h_pos x_4816 +| Neg x_4817 -> h_neg x_4817 + +(** val z_inv_rect_Type4 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 **) +let z_inv_rect_Type4 hterm h1 h2 h3 = + let hcut = z_rect_Type4 h1 h2 h3 hterm in hcut __ + +(** val z_inv_rect_Type3 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 **) +let z_inv_rect_Type3 hterm h1 h2 h3 = + let hcut = z_rect_Type3 h1 h2 h3 hterm in hcut __ + +(** val z_inv_rect_Type2 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 **) +let z_inv_rect_Type2 hterm h1 h2 h3 = + let hcut = z_rect_Type2 h1 h2 h3 hterm in hcut __ + +(** val z_inv_rect_Type1 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 **) +let z_inv_rect_Type1 hterm h1 h2 h3 = + let hcut = z_rect_Type1 h1 h2 h3 hterm in hcut __ + +(** val z_inv_rect_Type0 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 **) +let z_inv_rect_Type0 hterm h1 h2 h3 = + let hcut = z_rect_Type0 h1 h2 h3 hterm in hcut __ + +(** val z_discr : z -> z -> __ **) +let z_discr x y = + Logic.eq_rect_Type2 x + (match x with + | OZ -> Obj.magic (fun _ dH -> dH) + | Pos a0 -> Obj.magic (fun _ dH -> dH __) + | Neg a0 -> Obj.magic (fun _ dH -> dH __)) y + +(** val z_of_nat : Nat.nat -> z **) +let z_of_nat = function +| Nat.O -> OZ +| Nat.S n0 -> Pos (Positive.succ_pos_of_nat n0) + +(** val neg_Z_of_nat : Nat.nat -> z **) +let neg_Z_of_nat = function +| Nat.O -> OZ +| Nat.S n0 -> Neg (Positive.succ_pos_of_nat n0) + +(** val abs : z -> Nat.nat **) +let abs = function +| OZ -> Nat.O +| Pos n -> Positive.nat_of_pos n +| Neg n -> Positive.nat_of_pos n + +(** val oZ_test : z -> Bool.bool **) +let oZ_test = function +| OZ -> Bool.True +| Pos x -> Bool.False +| Neg x -> Bool.False + +(** val zsucc : z -> z **) +let zsucc = function +| OZ -> Pos Positive.One +| Pos n -> Pos (Positive.succ n) +| Neg n -> + (match n with + | Positive.One -> OZ + | Positive.P1 x -> Neg (Positive.pred n) + | Positive.P0 x -> Neg (Positive.pred n)) + +(** val zpred : z -> z **) +let zpred = function +| OZ -> Neg Positive.One +| Pos n -> + (match n with + | Positive.One -> OZ + | Positive.P1 x -> Pos (Positive.pred n) + | Positive.P0 x -> Pos (Positive.pred n)) +| Neg n -> Neg (Positive.succ n) + +(** val eqZb : z -> z -> Bool.bool **) +let rec eqZb x y = + match x with + | OZ -> + (match y with + | OZ -> Bool.True + | Pos q -> Bool.False + | Neg q -> Bool.False) + | Pos p -> + (match y with + | OZ -> Bool.False + | Pos q -> Positive.eqb p q + | Neg q -> Bool.False) + | Neg p -> + (match y with + | OZ -> Bool.False + | Pos q -> Bool.False + | Neg q -> Positive.eqb p q) + +(** val z_compare : z -> z -> Positive.compare **) +let rec z_compare x y = + match x with + | OZ -> + (match y with + | OZ -> Positive.EQ + | Pos m -> Positive.LT + | Neg m -> Positive.GT) + | Pos n -> + (match y with + | OZ -> Positive.GT + | Pos m -> Positive.pos_compare n m + | Neg m -> Positive.GT) + | Neg n -> + (match y with + | OZ -> Positive.LT + | Pos m -> Positive.LT + | Neg m -> Positive.pos_compare m n) + +(** val zplus : z -> z -> z **) +let rec zplus x y = + match x with + | OZ -> y + | Pos m -> + (match y with + | OZ -> x + | Pos n -> Pos (Positive.plus m n) + | Neg n -> + (match Positive.pos_compare m n with + | Positive.LT -> Neg (Positive.minus n m) + | Positive.EQ -> OZ + | Positive.GT -> Pos (Positive.minus m n))) + | Neg m -> + (match y with + | OZ -> x + | Pos n -> + (match Positive.pos_compare m n with + | Positive.LT -> Pos (Positive.minus n m) + | Positive.EQ -> OZ + | Positive.GT -> Neg (Positive.minus m n)) + | Neg n -> Neg (Positive.plus m n)) + +(** val zopp : z -> z **) +let zopp = function +| OZ -> OZ +| Pos n -> Neg n +| Neg n -> Pos n + +(** val zminus : z -> z -> z **) +let zminus x y = + zplus x (zopp y) + +(** val z_two_power_nat : Nat.nat -> z **) +let z_two_power_nat n = + Pos (Positive.two_power_nat n) + +(** val z_two_power_pos : Positive.pos -> z **) +let z_two_power_pos n = + Pos (Positive.two_power_pos n) + +(** val two_p : z -> z **) +let two_p = function +| OZ -> Pos Positive.One +| Pos p -> Pos (Positive.two_power_pos p) +| Neg x -> OZ + +open Types + +(** val decidable_eq_Z_Type : z -> z -> (__, __) Types.sum **) +let decidable_eq_Z_Type z1 z2 = + (match eqZb z1 z2 with + | Bool.True -> (fun _ -> Types.Inl __) + | Bool.False -> (fun _ -> Types.Inr __)) __ + +(** val zleb : z -> z -> Bool.bool **) +let rec zleb x y = + match x with + | OZ -> + (match y with + | OZ -> Bool.True + | Pos m -> Bool.True + | Neg m -> Bool.False) + | Pos n -> + (match y with + | OZ -> Bool.False + | Pos m -> Positive.leb n m + | Neg m -> Bool.False) + | Neg n -> + (match y with + | OZ -> Bool.True + | Pos m -> Bool.True + | Neg m -> Positive.leb m n) + +(** val zltb : z -> z -> Bool.bool **) +let rec zltb x y = + match x with + | OZ -> + (match y with + | OZ -> Bool.False + | Pos m -> Bool.True + | Neg m -> Bool.False) + | Pos n -> + (match y with + | OZ -> Bool.False + | Pos m -> Positive.leb (Positive.succ n) m + | Neg m -> Bool.False) + | Neg n -> + (match y with + | OZ -> Bool.True + | Pos m -> Bool.True + | Neg m -> Positive.leb (Positive.succ m) n) + +(** val zleb_elim_Type0 : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let zleb_elim_Type0 n m hle hnle = + Bool.bool_rect_Type0 (fun _ -> hle __) (fun _ -> hnle __) (zleb n m) __ + +(** val zltb_elim_Type0 : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) +let zltb_elim_Type0 n m hlt hnlt = + Bool.bool_rect_Type0 (fun _ -> hlt __) (fun _ -> hnlt __) (zltb n m) __ + +(** val z_times : z -> z -> z **) +let rec z_times x y = + match x with + | OZ -> OZ + | Pos n -> + (match y with + | OZ -> OZ + | Pos m -> Pos (Positive.times n m) + | Neg m -> Neg (Positive.times n m)) + | Neg n -> + (match y with + | OZ -> OZ + | Pos m -> Neg (Positive.times n m) + | Neg m -> Pos (Positive.times n m)) + +(** val zmax : z -> z -> z **) +let zmax x y = + match z_compare x y with + | Positive.LT -> y + | Positive.EQ -> x + | Positive.GT -> x + diff --git a/extracted/z.mli b/extracted/z.mli new file mode 100644 index 0000000..f5d97f3 --- /dev/null +++ b/extracted/z.mli @@ -0,0 +1,107 @@ +open Preamble + +open Bool + +open Relations + +open Nat + +open Hints_declaration + +open Core_notation + +open Pts + +open Logic + +open Positive + +type z = +| OZ +| Pos of Positive.pos +| Neg of Positive.pos + +val z_rect_Type4 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 + +val z_rect_Type5 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 + +val z_rect_Type3 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 + +val z_rect_Type2 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 + +val z_rect_Type1 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 + +val z_rect_Type0 : + 'a1 -> (Positive.pos -> 'a1) -> (Positive.pos -> 'a1) -> z -> 'a1 + +val z_inv_rect_Type4 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 + +val z_inv_rect_Type3 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 + +val z_inv_rect_Type2 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 + +val z_inv_rect_Type1 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 + +val z_inv_rect_Type0 : + z -> (__ -> 'a1) -> (Positive.pos -> __ -> 'a1) -> (Positive.pos -> __ -> + 'a1) -> 'a1 + +val z_discr : z -> z -> __ + +val z_of_nat : Nat.nat -> z + +val neg_Z_of_nat : Nat.nat -> z + +val abs : z -> Nat.nat + +val oZ_test : z -> Bool.bool + +val zsucc : z -> z + +val zpred : z -> z + +val eqZb : z -> z -> Bool.bool + +val z_compare : z -> z -> Positive.compare + +val zplus : z -> z -> z + +val zopp : z -> z + +val zminus : z -> z -> z + +val z_two_power_nat : Nat.nat -> z + +val z_two_power_pos : Positive.pos -> z + +val two_p : z -> z + +open Types + +val decidable_eq_Z_Type : z -> z -> (__, __) Types.sum + +val zleb : z -> z -> Bool.bool + +val zltb : z -> z -> Bool.bool + +val zleb_elim_Type0 : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val zltb_elim_Type0 : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + +val z_times : z -> z -> z + +val zmax : z -> z -> z + diff --git a/options.ml b/options.ml new file mode 100644 index 0000000..caedec2 --- /dev/null +++ b/options.ml @@ -0,0 +1,188 @@ +(*open Misc.ArgExt replaced by next line*) +let extra_doc s = "", Arg.Unit ignore, s + +(* +let web_mode = ref false +let is_web_mode () = !web_mode +let set_web_mode () = web_mode := true +*) + +(* +let default_choice = "default" +let option_settings_step = "during option settings" + +let language_from_string kind default s = + try + Languages.from_string s + with Not_found -> + if s = default_choice then + default + else + Error.global_error option_settings_step + (Printf.sprintf "`%s' is not a valid %s language." s kind) + +let source_language_of_string = language_from_string "source" Languages.Clight +let source_language = ref (source_language_of_string default_choice) +let set_source_language s = source_language := source_language_of_string s +let get_source_language () = !source_language + +let target_language_of_string = language_from_string "target" Languages.ASM +let target_language = ref (target_language_of_string default_choice) +let set_target_language s = target_language := target_language_of_string s +let get_target_language () = !target_language +*) + +(* +let input_files = ref [] +let add_input_file f = input_files := f :: !input_files +let input_files () = !input_files +*) + +let output_files = ref None +let set_output_files s = output_files := Some s +let get_output_files () = !output_files + +let annotation_flag = ref false +let request_annotation = (:=) annotation_flag +let annotation_requested () = !annotation_flag + +(* +let interpretation_flag = ref false +let request_interpretation = (:=) interpretation_flag +let interpretation_requested () = !interpretation_flag +*) + +let interpretations_flag = ref false +let request_interpretations = (:=) interpretations_flag +let interpretations_requested () = !interpretations_flag + +(* +let debug_flag = ref false +let set_debug = (:=) debug_flag +let is_debug_enabled () = !debug_flag +*) + +(* +let asm_pretty_flag = ref false +let set_asm_pretty = (:=) asm_pretty_flag +let is_asm_pretty () = !asm_pretty_flag +*) + +let lustre_flag = ref false +let set_lustre_file = (:=) lustre_flag +let is_lustre_file () = !lustre_flag + +let remove_lustre_externals = ref false +let set_remove_lustre_externals = (:=) remove_lustre_externals +let is_remove_lustre_externals () = !remove_lustre_externals + +let lustre_test = ref None +let set_lustre_test s = lustre_test := Some s +let get_lustre_test () = !lustre_test + +let lustre_test_cases = ref 100 +let set_lustre_test_cases = (:=) lustre_test_cases +let get_lustre_test_cases () = !lustre_test_cases + +let lustre_test_cycles = ref 100 +let set_lustre_test_cycles = (:=) lustre_test_cycles +let get_lustre_test_cycles () = !lustre_test_cycles + +let lustre_test_min_int = ref (-1000) +let set_lustre_test_min_int = (:=) lustre_test_min_int +let get_lustre_test_min_int () = !lustre_test_min_int + +let lustre_test_max_int = ref 1000 +let set_lustre_test_max_int = (:=) lustre_test_max_int +let get_lustre_test_max_int () = !lustre_test_max_int + +(* +let print_result_flag = ref false +let set_print_result = (:=) print_result_flag +let is_print_result_enabled () = !print_result_flag +*) + +(* +let dev_test = ref false +let set_dev_test = (:=) dev_test +let is_dev_test_enabled () = !dev_test +*) + +let options = OptionsParsing.register [ +(* + "-s", Arg.String set_source_language, + " Choose the source language between:"; + extra_doc " Clight, Cminor"; + extra_doc " [default is C]"; + + "-l", Arg.String set_target_language, + " Choose the target language between:"; + extra_doc " Clight, Cminor, RTLabs, RTL, ERTL, LTL, LIN, ASM"; + extra_doc " [default is ASM]"; +*) + + "-a", Arg.Set annotation_flag, + " Add cost annotations on the source code."; + +(* + "-i", Arg.Set interpretation_flag, + " Interpret the compiled code."; +*) + + "-is", Arg.Set interpretations_flag, + " Outputs and interprets all the compilation passes,"; + extra_doc " showing the execution traces"; + +(* + "-d", Arg.Set debug_flag, + " Debug mode."; + extra_doc " Outputs all the passes up to the target language."; + extra_doc " Combined with an interpret option, shows the trace"; + extra_doc " of execution states."; +*) + + "-o", Arg.String set_output_files, + " Prefix of the output files."; + +(* + "-asm-pretty", Arg.Set asm_pretty_flag, + " Output a pretty-printed assembly file."; +*) + + "-lustre", Arg.Set lustre_flag, + " Input file is a Lustre file."; + + "-remove-lustre-externals", Arg.Set remove_lustre_externals, + " Remove Lustre externals."; + + "-lustre-test", Arg.String set_lustre_test, + " Input file is a Lustre file, testing requested."; + + "-lustre-test-cases", Arg.Int set_lustre_test_cases, + " Set the number of test cases when testing a Lustre"; + extra_doc " file."; + extra_doc " [default is 100]"; + + "-lustre-test-cycles", Arg.Int set_lustre_test_cycles, + " Set the number of cycles for each case when testing"; + extra_doc " a Lustre file."; + extra_doc " [default is 100]"; + + "-lustre-test-min-int", Arg.Int set_lustre_test_min_int, + " Random int minimum value when testing a Lustre file."; + extra_doc " [default is -1000]"; + + "-lustre-test-max-int", Arg.Int set_lustre_test_max_int, + " Random int maximum value when testing a Lustre file."; + extra_doc " [default is 1000]"; + +(* + "-res", Arg.Set print_result_flag, + " Print the result of interpretations."; +*) + +(* + "-dev", Arg.Set dev_test, + " Playground for developers."; +*) +] diff --git a/options.mli b/options.mli new file mode 100644 index 0000000..a6ec541 --- /dev/null +++ b/options.mli @@ -0,0 +1,90 @@ +(** This module defines the compiler general options. *) + +(* +(** {2 Source language} *) +val set_source_language : string -> unit +val get_source_language : unit -> Languages.name + +(** {2 Target language} *) +val set_target_language : string -> unit +val get_target_language : unit -> Languages.name +*) + +(* +(** {2 Interpretation request} *) +val request_interpretation : bool -> unit +val interpretation_requested : unit -> bool +*) + +(** {2 Interpretation requests} *) +val request_interpretations : bool -> unit +val interpretations_requested : unit -> bool + +(** {2 Annotation requests} *) +val request_annotation : bool -> unit +val annotation_requested : unit -> bool + +(* +(** {2 Input files} *) +val add_input_file : string -> unit +val input_files : unit -> string list +*) + +(** {2 Output files} *) +val set_output_files : string -> unit +val get_output_files : unit -> string option + +(* +(** {2 Verbose mode} *) +val is_debug_enabled : unit -> bool +*) + +(* +(** {2 Assembly pretty print} *) +val set_asm_pretty : bool -> unit +val is_asm_pretty : unit -> bool +*) + +(** {2 Lustre file} *) +val set_lustre_file : bool -> unit +val is_lustre_file : unit -> bool + +(** {2 Remove Lustre externals} *) +val set_remove_lustre_externals : bool -> unit +val is_remove_lustre_externals : unit -> bool + +(** {2 Lustre file and test requested} *) +val set_lustre_test : string -> unit +val get_lustre_test : unit -> string option + +(** {2 Lustre file: number of test cases} *) +val set_lustre_test_cases : int -> unit +val get_lustre_test_cases : unit -> int + +(** {2 Lustre file: number of cycles for each case} *) +val set_lustre_test_cycles : int -> unit +val get_lustre_test_cycles : unit -> int + +(** {2 Lustre file: random int minimum value} *) +val set_lustre_test_min_int : int -> unit +val get_lustre_test_min_int : unit -> int + +(** {2 Lustre file: random int maximum value} *) +val set_lustre_test_max_int : int -> unit +val get_lustre_test_max_int : unit -> int + +(* +(** {2 Print results requests} *) +val is_print_result_enabled : unit -> bool +*) + +(* +(** {2 Developers' playground} *) +val is_dev_test_enabled : unit -> bool +*) + +(* +(** {2 Web application} *) +val set_web_mode : unit -> unit +val is_web_mode : unit -> bool +*) diff --git a/optionsParsing.ml b/optionsParsing.ml new file mode 100644 index 0000000..9f46bc4 --- /dev/null +++ b/optionsParsing.ml @@ -0,0 +1,16 @@ +let options = ref [] + +let register o = + options := o @ !options + +let results () = + let usage_msg = + "Usage: " + ^ (Filename.basename Sys.executable_name) + ^ " [options] file..." + in + let extra_arguments = ref [] in + Arg.parse (Arg.align !options) + (fun s -> extra_arguments := s :: !extra_arguments) + usage_msg; + !extra_arguments diff --git a/printer.ml b/printer.ml new file mode 100644 index 0000000..8d739de --- /dev/null +++ b/printer.ml @@ -0,0 +1,269 @@ +let print_keyword = + function + | Extracted.Joint_printer.KwCOMMENT -> "COMMENT" + | Extracted.Joint_printer.KwMOVE -> "MOVE" + | Extracted.Joint_printer.KwPOP -> "POP" + | Extracted.Joint_printer.KwPUSH -> "PUSH" + | Extracted.Joint_printer.KwADDRESS -> "ADDRESS" + | Extracted.Joint_printer.KwOPACCS -> "OPACCS" + | Extracted.Joint_printer.KwOP1 -> "OP1" + | Extracted.Joint_printer.KwOP2 -> "OP2" + | Extracted.Joint_printer.KwCLEAR_CARRY -> "CLEAR_CARRY" + | Extracted.Joint_printer.KwSET_CARRY -> "SET_CARRY" + | Extracted.Joint_printer.KwLOAD -> "LOAD" + | Extracted.Joint_printer.KwSTORE -> "STORE" + | Extracted.Joint_printer.KwCOST_LABEL -> "COST_LABEL" + | Extracted.Joint_printer.KwCOND -> "COND" + | Extracted.Joint_printer.KwCALL -> "CALL" + | Extracted.Joint_printer.KwGOTO -> "GOTO" + | Extracted.Joint_printer.KwRETURN -> "RETURN" + | Extracted.Joint_printer.KwTAILCALL -> "TAILCALL" + | Extracted.Joint_printer.KwFCOND -> "FCOND" + +let print_opAccs = + function + | Extracted.BackEndOps.Mul -> "Mul" + | Extracted.BackEndOps.DivuModu -> "DivModu" + +let print_op1 = + function + | Extracted.BackEndOps.Cmpl -> "Cmpl" + | Extracted.BackEndOps.Inc -> "Inc" + | Extracted.BackEndOps.Rl -> "Rl" + +let print_op2 = + function + | Extracted.BackEndOps.Add -> "Add" + | Extracted.BackEndOps.Addc -> "Addc" + | Extracted.BackEndOps.Sub -> "Sub" + | Extracted.BackEndOps.And -> "And" + | Extracted.BackEndOps.Or -> "Or" + | Extracted.BackEndOps.Xor -> "Xor" + +(* Duplicated, also in cerco.ml! *) +let string_of_pos n = string_of_int (Extracted.Glue.int_of_matitapos n) + +let print_ident n = "fun_" ^ string_of_pos n + +let printing_pass_independent_params = + { Extracted.Joint_printer.print_String = + (fun Extracted.String.EmptyString -> "EmptyString") + ; print_keyword = print_keyword + ; print_concat = (fun s1 s2 -> s1 ^ " " ^ s2) + ; print_empty = "" + ; print_ident = print_ident + ; print_costlabel = (fun n -> "k_" ^ string_of_pos n) + ; print_label = (fun n -> "l_" ^ string_of_pos n) + ; print_OpAccs = print_opAccs + ; print_Op1 = print_op1 + ; print_Op2 = print_op2 + ; print_nat = (fun n -> string_of_int (Extracted.Glue.int_of_matitanat n)) + ; print_bitvector = (fun _ n -> string_of_int (Extracted.Glue.int_of_bitvector n)) + } + +let print_byte b = string_of_int (IntelHex.int_of_vect b) + +let print_argument print_arg = + function + Extracted.Joint.Imm b -> print_byte b + | Extracted.Joint.Reg x -> print_arg x + +let print_Register = + function + | Extracted.I8051.Register00 -> "Register00" + | Extracted.I8051.Register01 -> "Register01" + | Extracted.I8051.Register02 -> "Register02" + | Extracted.I8051.Register03 -> "Register03" + | Extracted.I8051.Register04 -> "Register04" + | Extracted.I8051.Register05 -> "Register05" + | Extracted.I8051.Register06 -> "Register06" + | Extracted.I8051.Register07 -> "Register07" + | Extracted.I8051.Register10 -> "Register10" + | Extracted.I8051.Register11 -> "Register11" + | Extracted.I8051.Register12 -> "Register12" + | Extracted.I8051.Register13 -> "Register13" + | Extracted.I8051.Register14 -> "Register14" + | Extracted.I8051.Register15 -> "Register15" + | Extracted.I8051.Register16 -> "Register16" + | Extracted.I8051.Register17 -> "Register17" + | Extracted.I8051.Register20 -> "Register20" + | Extracted.I8051.Register21 -> "Register21" + | Extracted.I8051.Register22 -> "Register22" + | Extracted.I8051.Register23 -> "Register23" + | Extracted.I8051.Register24 -> "Register24" + | Extracted.I8051.Register25 -> "Register25" + | Extracted.I8051.Register26 -> "Register26" + | Extracted.I8051.Register27 -> "Register27" + | Extracted.I8051.Register30 -> "Register30" + | Extracted.I8051.Register31 -> "Register31" + | Extracted.I8051.Register32 -> "Register32" + | Extracted.I8051.Register33 -> "Register33" + | Extracted.I8051.Register34 -> "Register34" + | Extracted.I8051.Register35 -> "Register35" + | Extracted.I8051.Register36 -> "Register36" + | Extracted.I8051.Register37 -> "Register37" + | Extracted.I8051.RegisterA -> "RegisterA" + | Extracted.I8051.RegisterB -> "RegisterB" + | Extracted.I8051.RegisterDPL -> "RegisterDPL" + | Extracted.I8051.RegisterDPH -> "RegisterDPH" + | Extracted.I8051.RegisterCarry -> "RegisterCarry" + +let print_registers_move = + function + | Extracted.Joint_LTL_LIN.From_acc (reg,_unit) -> + print_Register reg ^ " " ^ "ACC_A" + | Extracted.Joint_LTL_LIN.To_acc (_unit,reg) -> + "ACC_A " ^ print_Register reg + | Extracted.Joint_LTL_LIN.Int_to_reg (reg,byte) -> + print_Register reg ^ " " ^ print_byte byte + | Extracted.Joint_LTL_LIN.Int_to_acc (_unit,byte) -> + "ACC_A " ^ print_byte byte + +let print_register n = "r_" ^ string_of_pos n + +let rTL_printing_params = + { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params + ; print_acc_a_reg = Obj.magic print_register + ; print_acc_b_reg = Obj.magic print_register + ; print_acc_a_arg = Obj.magic (print_argument print_register) + ; print_acc_b_arg = Obj.magic (print_argument print_register) + ; print_dpl_reg = Obj.magic print_register + ; print_dph_reg = Obj.magic print_register + ; print_dpl_arg = Obj.magic (print_argument print_register) + ; print_dph_arg = Obj.magic (print_argument print_register) + ; print_snd_arg = Obj.magic (print_argument print_register) + ; print_pair_move = Obj.magic + (fun {Extracted.Types.fst = reg; snd = arg} -> + print_register reg ^ " " ^ print_argument print_register arg) + ; print_call_args = Obj.magic + (fun l -> String.concat " " (List.map (print_argument print_register) l)) + ; print_call_dest = Obj.magic + (fun l -> String.concat " " (List.map print_register l)) + ; print_ext_seq = + (fun ext -> + match Obj.magic ext with + Extracted.RTL.Rtl_stack_address (reg1,reg2) -> + "Rtl_stack_address " ^ print_register reg1 ^ " " ^ print_register reg2) + } + +let print_move_dst = + function + Extracted.ERTL.PSD reg -> print_register reg + | Extracted.ERTL.HDW reg -> print_Register reg + +let eRTL_printing_params = + { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params + ; print_acc_a_reg = Obj.magic print_register + ; print_acc_b_reg = Obj.magic print_register + ; print_acc_a_arg = Obj.magic (print_argument print_register) + ; print_acc_b_arg = Obj.magic (print_argument print_register) + ; print_dpl_reg = Obj.magic print_register + ; print_dph_reg = Obj.magic print_register + ; print_dpl_arg = Obj.magic (print_argument print_register) + ; print_dph_arg = Obj.magic (print_argument print_register) + ; print_snd_arg = Obj.magic (print_argument print_register) + ; print_pair_move = Obj.magic + (fun {Extracted.Types.fst = dst; snd = src} -> + print_move_dst dst ^ " " ^ print_argument print_move_dst src ) + ; print_call_args = + Obj.magic (fun n -> string_of_int (Extracted.Glue.int_of_matitanat n)) + ; print_call_dest = (fun _ -> "") + ; print_ext_seq = + (fun ext -> match Obj.magic ext with + | Extracted.ERTL.Ertl_new_frame -> "NEW FRAME" + | Extracted.ERTL.Ertl_del_frame -> "DEL FRAME" + | Extracted.ERTL.Ertl_frame_size r -> "FRAMESIZE " ^ print_register r) + } + +let joint_LTL_LIN_printing_params = + { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params + ; print_acc_a_reg = (fun _ -> "ACC_A") + ; print_acc_b_reg = (fun _ -> "ACC_B") + ; print_acc_a_arg = (fun _ -> "ACC_A") + ; print_acc_b_arg = (fun _ -> "ACC_B") + ; print_dpl_reg = (fun _ -> "DPL") + ; print_dph_reg = (fun _ -> "DPH") + ; print_dpl_arg = (fun _ -> "DPL") + ; print_dph_arg = (fun _ -> "DPH") + ; print_snd_arg = (fun hdw_arg -> print_argument print_Register (Obj.magic hdw_arg)) + ; print_pair_move = Obj.magic print_registers_move + ; print_call_args = + (fun n ->string_of_int (Extracted.Glue.int_of_matitanat (Obj.magic n))) + ; print_call_dest = (fun _ -> "") + ; print_ext_seq = + (fun ext -> match Obj.magic ext with + | Extracted.Joint_LTL_LIN.SAVE_CARRY -> "SAVE_CARRY" + | Extracted.Joint_LTL_LIN.RESTORE_CARRY -> "RESTORE_CARRY" + | Extracted.Joint_LTL_LIN.HIGH_ADDRESS l -> + Format.sprintf "HIGH_ADDRESS l_%d" (Extracted.Glue.int_of_matitapos l) + | Extracted.Joint_LTL_LIN.LOW_ADDRESS l -> + Format.sprintf "LOW_ADDRESS l_%d" (Extracted.Glue.int_of_matitapos l)) + } + +let rec list_of_matitalist = + function + Extracted.List.Nil -> [] + | Extracted.List.Cons (hd,tl) -> hd :: list_of_matitalist tl + +let print_graph l = + let l = list_of_matitalist l in + String.concat "\n\n" + (List.map + (fun {Extracted.Types.fst=ident; snd=commands} -> + let commands = list_of_matitalist commands in + print_ident ident ^ ":\n" ^ + String.concat "\n" (List.rev commands) + ) + l) + +let extension_of_pass = + function + | Extracted.Compiler.Clight_pass -> "clight" + | Extracted.Compiler.Clight_switch_removed_pass -> "clight_sr" + | Extracted.Compiler.Clight_label_pass -> "clight_l" + | Extracted.Compiler.Clight_simplified_pass -> "clight_s" + | Extracted.Compiler.Cminor_pass -> "cminor" + | Extracted.Compiler.Rtlabs_pass -> "rtlabs" + | Extracted.Compiler.Rtl_separate_pass -> "rtl" + | Extracted.Compiler.Rtl_uniq_pass -> "rtl_u" + | Extracted.Compiler.Ertl_pass -> "ertl" + | Extracted.Compiler.Ltl_pass -> "ltl" + | Extracted.Compiler.Lin_pass -> "lin" + | Extracted.Compiler.Assembly_pass -> "assembly" + | Extracted.Compiler.Object_code_pass -> "hex" +;; + + +let print_program sourcename pass (program : Extracted.Preamble.__) = + let beprint pcs = + print_graph (pcs (Extracted.Types.fst (Obj.magic program))) in + let lines = + match pass with + | Extracted.Compiler.Clight_pass + | Extracted.Compiler.Clight_switch_removed_pass + | Extracted.Compiler.Clight_label_pass + | Extracted.Compiler.Clight_simplified_pass -> + ClightPrinter.print_program ClightPrinter.Cost_plain (Obj.magic program) + | Extracted.Compiler.Rtlabs_pass -> + RTLabsPrinter.print_program (Obj.magic program) + | Extracted.Compiler.Rtl_separate_pass -> + beprint (Extracted.RTL_printer.print_RTL_program rTL_printing_params) + | Extracted.Compiler.Rtl_uniq_pass -> + beprint (Extracted.RTL_printer.print_RTL_program rTL_printing_params) + | Extracted.Compiler.Ertl_pass -> + beprint (Extracted.ERTL_printer.print_ERTL_program eRTL_printing_params) + | Extracted.Compiler.Ltl_pass -> + beprint + (Extracted.LTL_printer.print_LTL_program joint_LTL_LIN_printing_params) + | Extracted.Compiler.Lin_pass -> + beprint + (Extracted.LIN_printer.print_LIN_program joint_LTL_LIN_printing_params) + | Extracted.Compiler.Object_code_pass -> + ASMPrinter.print_program (Obj.magic program) + | _ -> "" + in + let filename = + Filename.chop_extension sourcename ^ "." ^ extension_of_pass pass in + let och = open_out filename in + output_string och lines; + close_out och diff --git a/printer.mli b/printer.mli new file mode 100644 index 0000000..2bf553d --- /dev/null +++ b/printer.mli @@ -0,0 +1,2 @@ +val print_program: + string -> Extracted.Compiler.pass -> Extracted.Preamble.__ -> unit diff --git a/rTLabsPrinter.ml b/rTLabsPrinter.ml new file mode 100644 index 0000000..887294c --- /dev/null +++ b/rTLabsPrinter.ml @@ -0,0 +1,338 @@ +open Extracted.RTLabs_syntax + +open Extracted.FrontEndOps + +open Extracted.Integers + +(* +let n_spaces n = String.make n ' ' + + +let rec print_size = function + | AST.SQ q -> Memory.string_of_quantity q + | AST.SProd l -> "struct {" ^ (print_size_list l) ^ "}" + | AST.SSum l -> "union {" ^ (print_size_list l) ^ "}" + | AST.SArray (i, se) -> + (print_size se) ^ "[" ^ (string_of_int i) ^ "]" +and print_size_list l = + MiscPottier.string_of_list ", " print_size l + +let print_global_size = print_size + +let print_data = function +(* + | Data_reserve n -> Printf.sprintf "[%d]" n +*) + | AST.Data_int8 i -> Printf.sprintf "(int8) %d" i + | AST.Data_int16 i -> Printf.sprintf "(int16) %d" i + | AST.Data_int32 i -> Printf.sprintf "%d" i + | AST.Data_float32 f -> Printf.sprintf "%f" f + | AST.Data_float64 f -> Printf.sprintf "(float64) %f" f + +let print_datas init = + let rec aux = function + | [] -> "" + | [data] -> print_data data + | data :: datas -> Printf.sprintf "%s, %s" (print_data data) (aux datas) + in + Printf.sprintf "{%s}" (aux init) + +let print_datas_opt = function + | None -> "" + | Some init -> " = " ^ (print_datas init) + +let print_global n (id, size, init_opt) = + Printf.sprintf "%s\"%s\" : %s%s;\n" + (n_spaces n) id (print_global_size size) (print_datas_opt init_opt) + +let print_globals eformat n = + List.iter (fun v -> Eformat.printf eformat "%s" (print_global n v)) + + +let print_reg = Register.print + +let print_oreg = function + | None -> "_" + | Some r -> print_reg r + +let print_decl (r, t) = + (Primitive.print_type t) ^ " " ^ (Register.print r) + +let rec print_args args = + Printf.sprintf "[%s]" (MiscPottier.string_of_list ", " print_reg args) + +let print_result = function + | None -> "_" + | Some (r, t) -> (Primitive.print_type t) ^ " " ^ (Register.print r) + +let print_params r = + Printf.sprintf "(%s)" (MiscPottier.string_of_list ", " print_decl r) + +let print_locals r = + Printf.sprintf "%s" (MiscPottier.string_of_list ", " print_decl r) + + +let print_cmp = function + | AST.Cmp_eq -> "eq" + | AST.Cmp_ne -> "ne" + | AST.Cmp_gt -> "gt" + | AST.Cmp_ge -> "ge" + | AST.Cmp_lt -> "lt" + | AST.Cmp_le -> "le" + +let rec print_size = function + | AST.SQ q -> Memory.string_of_quantity q + | AST.SProd l -> "struct {" ^ (print_size_list l) ^ "}" + | AST.SSum l -> "union {" ^ (print_size_list l) ^ "}" + | AST.SArray (i, se) -> + (print_size se) ^ "[" ^ (string_of_int i) ^ "]" +and print_size_list l = + MiscPottier.string_of_list ", " print_size l + +let print_stacksize = print_size + +let print_offset (size, depth) = + (print_size size) ^ ", " ^ (string_of_int depth) + +let print_sizeof = print_size + +let string_of_signedness = function + | AST.Signed -> "s" + | AST.Unsigned -> "u" + +let string_of_int_type (size, sign) = + Printf.sprintf "%d%s" size (string_of_signedness sign) + +let print_op2 = function + | AST.Op_add -> "add" + | AST.Op_sub -> "sub" + | AST.Op_mul -> "mul" + | AST.Op_div -> "div" + | AST.Op_divu -> "/u" + | AST.Op_mod -> "mod" + | AST.Op_modu -> "modu" + | AST.Op_and -> "and" + | AST.Op_or -> "or" + | AST.Op_xor -> "xor" + | AST.Op_shl -> "shl" + | AST.Op_shr -> "shr" + | AST.Op_shru -> "shru" + | AST.Op_cmp cmp -> print_cmp cmp + | AST.Op_addp -> "addp" + | AST.Op_subp -> "subp" + | AST.Op_subpp -> "subpp" + | AST.Op_cmpp cmp -> (print_cmp cmp) ^ "p" + | AST.Op_cmpu cmp -> (print_cmp cmp) ^ "u" + + +(* +let print_addressing = function + | RTLabs.Aindexed off -> Printf.sprintf "{ %s }" (print_offset off) + | RTLabs.Aindexed2 -> "add" + | RTLabs.Aglobal (id, off) -> + Printf.sprintf "{ %s }(\"%s\")" (print_offset off) id + | RTLabs.Abased (id, off) -> + Printf.sprintf "add, { %s }(\"%s\")" (print_offset off) id + | RTLabs.Ainstack off -> Printf.sprintf "{ %s }(STACK)" (print_offset off) +*) + + +let rec print_table = function + | [] -> "" + | [lbl] -> lbl + | lbl :: tbl -> lbl ^ ", " ^ (print_table tbl) +*) +(* Duplicated, also in cerco.ml! *) +let string_of_pos n = string_of_int (Extracted.Glue.int_of_matitapos n) + +let print_identifier pref n = pref ^ "_" ^ string_of_pos n + +let print_fun_ident = print_identifier "fun" +let print_ident = print_identifier "id" +let print_label = print_identifier "l" +let print_reg = print_identifier "r" +let print_cost = print_identifier "k" + +let print_nat n = string_of_int (Extracted.Glue.int_of_matitanat n) + +let print_ubv bv = string_of_int (Extracted.Glue.int_of_bitvector bv) +let print_sbv bv = + let z = Extracted.BitVectorZ.z_of_signed_bitvector Extracted.Nat.O bv in + string_of_int (Extracted.Glue.int_of_matitaZ z) + + +let print_cst = function +| Ointconst (_, Extracted.AST.Signed, bv) -> print_sbv bv +| Ointconst (_, Extracted.AST.Unsigned, bv) -> print_ubv bv +| Oaddrsymbol (id, off) -> "&" ^ print_ident id ^ " + " ^ print_nat off +| Oaddrstack off -> "SP + " ^ print_nat off + +let print_signedness = function + | Extracted.AST.Signed -> "" + | Extracted.AST.Unsigned -> "u" + +let print_int_size = function + | Extracted.AST.I8 -> "8" + | Extracted.AST.I16 -> "16" + | Extracted.AST.I32 -> "32" + +let print_op1 = function +| Ocastint (src_sy, src_sign, dst_sy, dst_sign) -> + Format.sprintf "(%sint%s->%sint%s)" + (print_signedness src_sign) (print_int_size src_sy) + (print_signedness dst_sign) (print_int_size dst_sy) +| Onegint _ -> "-" +| Onotbool _ -> "!" +| Onotint _ -> "~" +| Oid _ -> "" +| Optrofint (sy, sign) -> + Format.sprintf "(%sint%s->ptr)" + (print_signedness sign) (print_int_size sy) +| Ointofptr (sy, sign) -> + Format.sprintf "(ptr->%sint%s)" + (print_signedness sign) (print_int_size sy) + +let print_comparison = function +| Ceq -> "==" +| Cne -> "!=" +| Clt -> "<" +| Cle -> "<=" +| Cgt -> ">" +| Cge -> ">=" + +let print_op2 = function +| Oadd _ -> "+" +| Osub _ -> "-" +| Omul _ -> "*" +| Odiv _ -> "/" +| Odivu _ -> "/u" +| Omod _ -> "%" +| Omodu _ -> "%u" +| Oand _ -> "&&" +| Oor _ -> "||" +| Oxor _ -> "^^" +| Oshl _ -> "<<" +| Oshr _ -> ">>" +| Oshru _ -> ">>u" +| Ocmp (_, _, _, cmp) -> print_comparison cmp +| Ocmpu (_, _, cmp) -> print_comparison cmp ^ "u" +| Oaddpi _ -> "p+" +| Oaddip _ -> "+p" +| Osubpi _ -> "p-" +| Osubpp _ -> "p-p" +| Ocmpp (_, cmp) -> print_comparison cmp ^ "p" + +let rec get_list = function + | Extracted.List.Nil -> [ ] + | Extracted.List.Cons (hd, tl) -> hd :: get_list tl + +let print_regs regs = + String.concat ", " (List.map print_reg (get_list regs)) + +let print_statement = function + | St_skip lbl -> "--> " ^ print_label lbl + | St_cost (cost_lbl, lbl) -> + Printf.sprintf "emit %s --> %s" + (print_cost cost_lbl) + (print_label lbl) + | St_const (_, destr, cst, lbl) -> + Printf.sprintf "%s = %s --> %s" + (print_reg destr) + (print_cst cst) + (print_label lbl) + | St_op1 (_, _, op, dst, src, lbl) -> + Format.sprintf "%s = %s%s --> %s" + (print_reg dst) (print_op1 op) (print_reg src) + (print_label lbl) + | St_op2 (_, _, _, op, dst, src1, src2, lbl) -> + Format.sprintf "%s = %s %s %s --> %s" + (print_reg dst) (print_reg src1) (print_op2 op) + (print_reg src2) (print_label lbl) + | St_load (_, addr, dst, lbl) -> + Format.sprintf "%s = *%s --> %s" + (print_reg dst) (print_reg addr) (print_label lbl) + | St_store (_, addr, src, lbl) -> + Format.sprintf "*%s = %s --> %s" + (print_reg addr) (print_reg src) (print_label lbl) + | St_call_id (id, args, Extracted.Types.Some dst, lbl) -> + Format.sprintf "%s = %s(%s) --> %s" + (print_reg dst) (print_fun_ident id) (print_regs args) + (print_label lbl) + | St_call_id (id, args, Extracted.Types.None, lbl) -> + Format.sprintf "%s(%s) --> %s" + (print_fun_ident id) (print_regs args) + (print_label lbl) + | St_call_ptr (addr, args, Extracted.Types.Some dst, lbl) -> + Format.sprintf "%s = *%s(%s) --> %s" + (print_reg dst) (print_reg addr) (print_regs args) + (print_label lbl) + | St_call_ptr (addr, args, Extracted.Types.None, lbl) -> + Format.sprintf "*%s(%s) --> %s" + (print_reg addr) (print_regs args) + (print_label lbl) + | St_cond (src, l_true, l_false) -> + Format.sprintf "if %s then --> %s else --> %s" + (print_reg src) (print_label l_true) (print_label l_false) + | St_return -> "return" + +let next = function + | St_skip lbl + | St_cost (_, lbl) + | St_const (_, _, _, lbl) + | St_op1 (_, _, _, _, _, lbl) + | St_op2 (_, _, _, _, _, _, _, lbl) + | St_load (_, _, _, lbl) + | St_store (_, _, _, lbl) + | St_call_id (_, _, _, lbl) + | St_call_ptr (_, _, _, lbl) -> [lbl] + | St_cond (_, l_true, l_false) -> [l_true ; l_false] + | St_return -> [ ] + +let get_bool = function + | Extracted.Bool.True -> true + | Extracted.Bool.False -> false + +let rec graph_dfs_aux f acc visiting visited graph = + match visiting with + | [ ] -> acc + | hd :: tl -> + let tag = Extracted.PreIdentifiers.LabelTag in + if get_bool (Extracted.Identifiers.member tag visited hd) then + graph_dfs_aux f acc tl visited graph + else + let visited = Extracted.Identifiers.add_set tag visited hd in + match Extracted.Identifiers.lookup tag graph hd with + | Extracted.Types.Some s -> + let acc = f hd s acc in + let visiting = next s @ tl in + graph_dfs_aux f acc visiting visited graph + | Extracted.Types.None -> + graph_dfs_aux f acc tl visited graph + +let graph_dfs f init entry = + graph_dfs_aux f init [entry] + (Extracted.Identifiers.empty_set Extracted.PreIdentifiers.LabelTag) + +let print_internal_function id def = + let regs = Extracted.List.map Extracted.Types.fst def.f_params in + let pre = Format.sprintf "def %s(%s):" + (print_fun_ident id) (print_regs regs) in + graph_dfs + (fun lbl s acc -> + Format.sprintf "%s\n %s: %s" acc (print_label lbl) (print_statement s)) + pre def.f_entry def.f_graph + +let print_external_function id _ = + Format.sprintf "ext %s" (print_fun_ident id) + +let print_function = function + | { Extracted.Types.fst = id ; + Extracted.Types.snd = Extracted.AST.Internal def } -> + print_internal_function id def + | { Extracted.Types.fst = id ; + Extracted.Types.snd = Extracted.AST.External def } -> + print_external_function id def + +let print_program prog = + let functs = get_list (prog.Extracted.AST.prog_funct) in + String.concat "\n\n" (List.map print_function functs) diff --git a/rTLabsPrinter.mli b/rTLabsPrinter.mli new file mode 100644 index 0000000..8e9cbd8 --- /dev/null +++ b/rTLabsPrinter.mli @@ -0,0 +1,6 @@ + +(** This module provides a function to print [RTLabs] programs. *) + +val print_statement : Extracted.RTLabs_syntax.statement -> string + +val print_program : Extracted.RTLabs_syntax.rTLabs_program -> string diff --git a/tests/PROBLEMI b/tests/PROBLEMI new file mode 100644 index 0000000..9047fd3 --- /dev/null +++ b/tests/PROBLEMI @@ -0,0 +1,9 @@ +1. ok +2. ok +3. ok +4. ok +5. ok +6. ok +7. ok +8. ok +bubble_sort.c: ok diff --git a/tests/bubble_sort.c b/tests/bubble_sort.c new file mode 100644 index 0000000..1f0a4cf --- /dev/null +++ b/tests/bubble_sort.c @@ -0,0 +1,41 @@ + +#define SIZE 5 + +char min (char tab[], char size, char n) { + char i, min_index, min; + + if (size == 0) return 0; + + min_index = n; + min = tab[min_index]; + for (i = n+1 ; i < size ; i++) { + if (tab[i] < min) { + min_index = i; + min = tab[min_index]; + } + } + + return min_index; +} + +void swap (char tab[], char i, char j) { + char t; + t = tab[i] ; tab[i] = tab[j] ; tab[j] = t; +} + +void bubble_sort(char tab[], char size) { + char i, min_index; + + for (i = 0 ; i < size ; i++) { + min_index = min(tab, size, i); + swap(tab, i, min_index); + } +} + +int main () { + char tab[] = {26, 21, 43, 62, 8}; + + bubble_sort(tab, SIZE); + + return (tab[3]); +} diff --git a/tests/test.c b/tests/test.c new file mode 100644 index 0000000..9da5827 --- /dev/null +++ b/tests/test.c @@ -0,0 +1,5 @@ +int main() { + int x = 0; + x += 4; + return x; +} diff --git a/tests/test2.c b/tests/test2.c new file mode 100644 index 0000000..05156f3 --- /dev/null +++ b/tests/test2.c @@ -0,0 +1,13 @@ +char a[] = {3, 2, 7, -4}; +char treshold = 4; + +int main() { + char j; + char *p = a; + int found = 0; + for (j=0; j < 4; j++) { + if (*p <= treshold) { found++; } + p++; + } + return found; +} diff --git a/tests/test3.c b/tests/test3.c new file mode 100644 index 0000000..f4eb505 --- /dev/null +++ b/tests/test3.c @@ -0,0 +1,5 @@ +char treshold = 7; + +int main() { + return treshold; +} diff --git a/tests/test4.c b/tests/test4.c new file mode 100644 index 0000000..6f4748d --- /dev/null +++ b/tests/test4.c @@ -0,0 +1,8 @@ +char decr(char x) { + if (x == 0) { return 0; } + else {return decr(x-1); } +} + +int main() { + return decr(4); +} diff --git a/tests/test5.c b/tests/test5.c new file mode 100644 index 0000000..87258bf --- /dev/null +++ b/tests/test5.c @@ -0,0 +1,3 @@ +int main() { + return ((char) 1 - (char)4); +} diff --git a/tests/test6.c b/tests/test6.c new file mode 100644 index 0000000..b796e6c --- /dev/null +++ b/tests/test6.c @@ -0,0 +1,9 @@ +int foo(int x) { + return (x+1); +} + +int main() { + int (*goo)(int x); + goo = foo; + return ((*goo)(3)); +} diff --git a/tests/test7.c b/tests/test7.c new file mode 100644 index 0000000..063b76d --- /dev/null +++ b/tests/test7.c @@ -0,0 +1,21 @@ +char a[] = {3, 2, 7, 1}; +char treshold = 4; + +unsigned int count(char(*foo)(char),char *a,int current, int high) { + int n = 0 ; + if (current < high) + { + n = (*foo)(a[current]); + current++; + n += count(foo,a,current,high); + } + return n; +} + +char smaller(char x) { + return (x < treshold); +} + +int main() { + return (count(smaller,a,0,4)); +} diff --git a/tests/test8.c b/tests/test8.c new file mode 100644 index 0000000..5f9d1e2 --- /dev/null +++ b/tests/test8.c @@ -0,0 +1,4 @@ +int main() { + int x = 4; + if (x == 4) { return 3; } else { return 5; } +} -- 2.39.2