зеркало из https://github.com/microsoft/SLAyer.git
fr original repo
This commit is contained in:
Samin Ishtiaq
Коммит
ee24563509
|
|
@ -0,0 +1,12 @@
|
|||
normal
|
||||
base = 2
|
||||
type = 2
|
||||
in = 0
|
||||
with = 0
|
||||
match_clause = 4
|
||||
max_indent = 2
|
||||
strict_with = auto
|
||||
strict_else = always
|
||||
strict_comments = true
|
||||
align_ops = true
|
||||
align_params = always
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
SLAyer
|
||||
|
||||
Copyright (c) Microsoft Corporation
|
||||
|
||||
All rights reserved.
|
||||
|
||||
MIT License
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ""Software""), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED *AS IS*, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
# About
|
||||
|
||||
SLAyer is an automatic formal verification tool that uses separation logic to verify memory safety of C programs.
|
||||
|
||||
# Licence
|
||||
|
||||
SLAyer is licensed under the MIT licence included in the [LICENSE](./LICENSE) file.
|
||||
|
||||
# Setup
|
||||
|
||||
Building and testing SLAyer has some dependencies on the environment.
|
||||
To set this up, start in a VS 201x shell. Then enter a bash shell, cd
|
||||
to here, and execute:
|
||||
|
||||
`$ source config.sh`
|
||||
|
||||
To build SLAyer:
|
||||
|
||||
`$ cd src; make; cd ..`
|
||||
|
||||
The slayer.exe will be left in the bin directory.
|
||||
|
||||
See src/README for additional building instructions.
|
||||
|
||||
To run the tests:
|
||||
|
||||
Start a new VS2010+bash shell, and cd to here. (The reason to start a
|
||||
new shell is that SLAyer is built using the usual VS compiler, but
|
||||
when slayer runs on tests, it needs to run the WDK compiler.)
|
||||
|
||||
`$ source ./config.sh`
|
||||
`$ cd test; source config.sh`
|
||||
|
||||
`$ cd sll`
|
||||
`$ slayer -vSE 3 -vAbs 2 traverse.c`
|
||||
|
||||
See test/README for additional testing instructions.
|
||||
|
||||
# Contributing
|
||||
|
||||
To contribute, you will need to complete a Contributor License Agreement (CLA).
|
||||
Briefly, this agreement testifies that you are granting us permission to use the submitted change according to the terms of the project's license,
|
||||
and that the work being submitted is under appropriate copyright.
|
||||
|
||||
Please submit a Contributor License Agreement (CLA) before submitting a pull request.
|
||||
You may visit https://cla.microsoft.com to sign digitally.
|
||||
Alternatively, download the agreement Microsoft Contribution License Agreement.docx or Microsoft Contribution License Agreement.pdf), sign, scan, and email it back to cla@microsoft.com.
|
||||
Be sure to include your github user name along with the agreement.
|
||||
Once we have received the signed CLA, we'll review the request.
|
||||
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
@echo off
|
||||
|
||||
REM SLAyer setup file.
|
||||
REM Most of these settings are for running slayer in stand-alone mode.
|
||||
REM slayer running under slam needs very little of this.
|
||||
|
||||
set SLWIN=%~dp0..
|
||||
|
||||
set PATH=%SLWIN%\SLAyer\bin;%PATH%
|
||||
set PATH=%SLWIN%\SLAyer\tools\bin;%PATH%
|
||||
set PATH=%SLWIN%\SLAyer\tools\Z3\build;%PATH%
|
||||
set PATH=%SLWIN%\SLAyer\tools\flexdll;%PATH%
|
||||
|
||||
REM sd merge.
|
||||
set PATH=%$PROGRAMFILES%\Emacs\emacs\bin;%PATH%
|
||||
set SDMERGE=%SLWIN%\SLAyer\tools\site-lisp\msel\mymerge.bat
|
||||
|
||||
REM dot
|
||||
set PATH=%PROGRAMFILES%\Graphviz2.27\bin;%PATH%
|
||||
|
||||
REM the directory the ocaml compiler executables are installed into
|
||||
set OCAML=%SLWIN%\SLAyer\tools\ocaml\bin
|
||||
|
||||
REM add ocaml compilers to PATH
|
||||
set PATH=%SLWIN%\SLAyer\tools\ocaml\bin;%PATH%
|
||||
|
||||
REM add ocaml library to INCLUDE, mainly for compiling C interface code
|
||||
set INCLUDE=%SLWIN%\SLAyer\tools\ocaml\lib;%INCLUDE%
|
||||
|
||||
REM must be in windows format
|
||||
set OCAMLLIB=%SLWIN%\SLAyer\tools\ocaml\lib
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
#!/bin/sh
|
||||
|
||||
# echo "Setting environment for building SLAyer"
|
||||
|
||||
|
||||
full=`pwd`/$BASH_SOURCE
|
||||
SL_SRC="${full%/*}/../"
|
||||
export SL_WIN=`cygpath -w $SL_SRC`
|
||||
export SL_UNIX=`cygpath -u $SL_WIN`
|
||||
#echo "Unix: $SL_UNIX Windows: $SL_WIN"
|
||||
|
||||
# add dirs slayer builds are installed into to PATH
|
||||
export PATH="$SL_UNIX/SLAyer/bin:$PATH"
|
||||
export PATH="$SL_UNIX/SLAyer/tools/Z3/build:$PATH"
|
||||
|
||||
# add ocaml compilers to PATH
|
||||
export PATH="$SL_UNIX/SLAyer/tools/ocaml/bin:$PATH"
|
||||
export PATH="$SL_UNIX/SLAyer/tools/ocaml/lib/stublibs:$PATH"
|
||||
export PATH="$SL_UNIX/SLAyer/tools/flexdll:$PATH"
|
||||
|
||||
# add ocaml library to INCLUDE, mainly for compiling C interface code
|
||||
export INCLUDE="$SL_WIN\SLAyer\tools\ocaml\lib;$INCLUDE"
|
||||
|
||||
# must be in windows format
|
||||
export OCAMLLIB="$SL_WIN\SLAyer\tools\ocaml\lib"
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
/* Copyright (c) Microsoft Corporation. All rights reserved. */
|
||||
|
||||
/*
|
||||
Declare convenient interface to SLAyer intrinsics.
|
||||
|
||||
When the "SLAyer" symbol is defined, analysis-specific definitions are used.
|
||||
Otherwise, executable definitions that under-approximate the SLAyer internal
|
||||
semantics are defined.
|
||||
|
||||
This file is included automatically when the SLAyer frontend invokes the C
|
||||
compiler. This default can be overridden by passing the SLAyer frontend the
|
||||
-no-builtins flag.
|
||||
|
||||
The "SLAyer" symbol is defined when SLAyer invokes the C compiler.
|
||||
*/
|
||||
|
||||
#ifndef _SLAYER_H_
|
||||
#define _SLAYER_H_
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <assert.h>
|
||||
|
||||
/* Provide executable definitions of SLAyer intrinsics unless SLAyer is defined. */
|
||||
#ifndef SLAyer
|
||||
|
||||
void* _SLAyer_malloc(size_t s) { return malloc(s); }
|
||||
void _SLAyer_free(void* p) { free(p); }
|
||||
|
||||
void _SLAyer_error() { assert(("reached point asserted to be erroneous", 0)); }
|
||||
void _SLAyer_unreachable() { assert(("reached point assumed to be unreachable", 0)); }
|
||||
|
||||
int _SLAyer_nondet() { return rand(); }
|
||||
|
||||
#endif // #ifndef SLAyer
|
||||
|
||||
#define container_of(ptr, type, member) _SLAyer_containerof(ptr, type, member)
|
||||
#define CONTAINING_RECORD(ptr, type, member) _SLAyer_containerof(ptr, type, member)
|
||||
|
||||
#define malloc(exp) _SLAyer_malloc(exp)
|
||||
#define free(exp) _SLAyer_free(exp)
|
||||
|
||||
#ifdef SLAyer
|
||||
/* Redefine the result of the definition of assert from assert.h to be robust
|
||||
with respect to code that includes assert.h (after slayer.h). */
|
||||
#define _wassert(_exp,_file,_line) _SLAyer_error()
|
||||
#endif
|
||||
#define assume(exp) _SLAyer_assume(exp)
|
||||
|
||||
#define nondet() _SLAyer_nondet()
|
||||
|
||||
|
||||
/* Deprecated */
|
||||
#define FAIL assert(0)
|
||||
#define FAIL_IF(_e) assert(!(_e))
|
||||
|
||||
#endif // #ifndef _SLAYER_H_
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
/* Copyright (c) Microsoft Corporation. All rights reserved. */
|
||||
|
||||
/*
|
||||
Declare SLAyer intrinsics.
|
||||
|
||||
SLAyer treats calls to the functions declared here specially, using internal
|
||||
analysis-specific semantics.
|
||||
|
||||
SLAyer recognizes and specially treats the code produced by the macro
|
||||
definitions, so it is not necessary to use the provided macro names.
|
||||
|
||||
This file is included automatically when SLAyer invokes the C compiler.
|
||||
*/
|
||||
|
||||
#ifndef _SLAYER_INTRINSICS_H_
|
||||
#define _SLAYER_INTRINSICS_H_
|
||||
|
||||
#define _SLAyer_NULL ((void *)0)
|
||||
|
||||
#ifdef _WIN64
|
||||
#define _SLAyer_offsetof(s,m) (size_t)( (__int64)&(((s *)0)->m) )
|
||||
#else
|
||||
#define _SLAyer_offsetof(s,m) (size_t)&(((s *)0)->m)
|
||||
#endif
|
||||
#define _SLAyer_containerof(ptr, type, member) ((type *) ((char *)(ptr) - _SLAyer_offsetof(type, member)))
|
||||
|
||||
#ifdef _WIN64
|
||||
void* _SLAyer_malloc(unsigned __int64);
|
||||
#else
|
||||
void* _SLAyer_malloc(unsigned int);
|
||||
#endif
|
||||
void _SLAyer_free(void*);
|
||||
|
||||
/* Calls to these functions other than through _SLAyer_assert or
|
||||
_SLAyer_assume may be translated suboptimally. */
|
||||
void _SLAyer_error(void);
|
||||
void _SLAyer_unreachable(void);
|
||||
|
||||
/* Translate to branches to avoid unnecessary bool->int->bool conversions. */
|
||||
/* Use a definition like assert.h except with _SLAyer_unreachable in place of
|
||||
_wassert to enable redefining the result of the standard definition. */
|
||||
#define _SLAyer_assert(exp) (void)( (!!(exp)) || (_SLAyer_error(), 0) )
|
||||
#define _SLAyer_assume(exp) (void)( (!!(exp)) || (_SLAyer_unreachable(), 0) )
|
||||
|
||||
int _SLAyer_nondet();
|
||||
|
||||
#endif // #ifndef _SLAYER_INTRINSICS_H_
|
||||
|
|
@ -0,0 +1 @@
|
|||
build_dir=_build
|
||||
|
|
@ -0,0 +1,617 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Abstract transition system abstract domains *)
|
||||
|
||||
(**/**)
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
module S = Substitution
|
||||
open Program
|
||||
module I = Inst
|
||||
module K = ControlPoint
|
||||
module C = Cmnd
|
||||
open Interproc_sig
|
||||
|
||||
module Positions = Set.Make(Position)
|
||||
|
||||
module L = (val Log.std Config.vATS : Log.LOG)
|
||||
module LSE = (val Log.std Config.vSE : Log.LOG)
|
||||
(**/**)
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Heights
|
||||
============================================================================*)
|
||||
|
||||
(* PS#207: heights should be a map from entry * pt to int *)
|
||||
module Heights = HashMap.Make(ControlPoint)
|
||||
|
||||
|
||||
module Domain
|
||||
(* states / vertex labels of the abstract transition system *)
|
||||
(RD: RELATION_DOMAIN) =
|
||||
struct
|
||||
|
||||
(*============================================================================
|
||||
Transition Relation from Relation Construction
|
||||
============================================================================*)
|
||||
|
||||
module RD = struct
|
||||
type r = RD.r
|
||||
|
||||
type pred = RD.pred
|
||||
|
||||
type t = { rel: RD.t; blk: I.t list; }
|
||||
|
||||
let create = RD.create
|
||||
|
||||
let inject x = {rel= RD.inject x; blk= []}
|
||||
|
||||
let project x = RD.project x.rel
|
||||
|
||||
let adapted_pre_substate_call r cxt pre call pcall =
|
||||
match RD.adapted_pre_substate_call r cxt pre.rel call.rel pcall with
|
||||
| Some(post_rel_to_retn_rel) -> Some(fun post -> {post with rel= post_rel_to_retn_rel post.rel})
|
||||
| None -> None
|
||||
|
||||
let call_to_entry r call pcall =
|
||||
let entry, post_rel_to_retn_rel = RD.call_to_entry r call.rel pcall in
|
||||
({rel= entry; blk= []}, (fun post -> {post with rel= post_rel_to_retn_rel post.rel}))
|
||||
|
||||
let exit_to_retn callee exit = {exit with rel= RD.exit_to_retn callee exit.rel}
|
||||
|
||||
let resolve_indirect_call r call fptr ftyp =
|
||||
RD.resolve_indirect_call r call.rel fptr ftyp
|
||||
|
||||
let error = {rel= RD.error; blk= []}
|
||||
|
||||
let tt = {rel= RD.tt; blk= []}
|
||||
|
||||
let is_error x = RD.is_error x.rel
|
||||
|
||||
let is_false x = RD.is_false x.rel
|
||||
|
||||
let exec_inst cxt i x =
|
||||
let rel = RD.exec_inst cxt i x.rel in
|
||||
let blk = match i with {I.desc= I.Nop} -> x.blk | _ -> i :: x.blk in
|
||||
{rel; blk}
|
||||
|
||||
let below x y = RD.below x.rel y.rel
|
||||
|
||||
let join x y = {rel= RD.join x.rel y.rel; blk= []}
|
||||
|
||||
let generalize x =
|
||||
let rel, jnk = RD.generalize x.rel in
|
||||
({x with rel}, jnk)
|
||||
|
||||
let compare x y =
|
||||
let o = RD.compare x.rel y.rel in if o <> 0 then o else
|
||||
List.compare I.compare x.blk y.blk
|
||||
|
||||
let equal x y = RD.equal x.rel y.rel && List.equal I.equal x.blk y.blk
|
||||
|
||||
let equal_entry x y = RD.equal_entry x.rel y.rel
|
||||
|
||||
let fmt ff {rel} = RD.fmt ff rel
|
||||
|
||||
let fmt_entry ff x = RD.fmt_entry ff x.rel
|
||||
|
||||
let fmt_pre ff (x,p) = RD.fmt_pre ff (x.rel,p)
|
||||
|
||||
let fmt_reln ff {rel; blk} =
|
||||
Format.fprintf ff "@[<hv>%a@ @[<hv>%a@]@ %a@]"
|
||||
RD.fmt_entry rel (List.fmt ";@ " I.fmt) (List.rev blk) RD.fmt rel
|
||||
end
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Transition / Edge Labels
|
||||
============================================================================*)
|
||||
|
||||
(* transitions / edge labels of the abstract transition system *)
|
||||
module Tr = struct
|
||||
|
||||
type t =
|
||||
| Intra of K.t * I.t list * K.t * bool (** start and end control points, block between, leak *)
|
||||
| Call of Proc.t Call.t
|
||||
| Return
|
||||
| Summary
|
||||
|
||||
|
||||
let append x y =
|
||||
match x, y with
|
||||
| Intra(k0,b0,k1,false), Intra(k1',b1,k2,false) when K.equal k1 k1' ->
|
||||
Some(Intra(k0, List.append b0 b1, k2, false))
|
||||
| _ ->
|
||||
None
|
||||
|
||||
let equal x y =
|
||||
match x, y with
|
||||
| Intra(k0,b0,k0',l0), Intra(k1,b1,k1',l1) ->
|
||||
K.equal k0 k1 && K.equal k0' k1' && List.equal I.equal b0 b1 && (l0 = l1)
|
||||
| Call(c0), Call(c1) ->
|
||||
Call.equal Proc.equal c0 c1
|
||||
| _ ->
|
||||
Pervasives.( = ) x y
|
||||
|
||||
let compare x y =
|
||||
match x, y with
|
||||
| Intra(k0,b0,k0',l0), Intra(k1,b1,k1',l1) ->
|
||||
let o = K.compare k0 k1 in if o <> 0 then o else
|
||||
let o = K.compare k0' k1' in if o <> 0 then o else
|
||||
let o = List.compare I.compare b0 b1 in if o <> 0 then o else
|
||||
Pervasives.compare l0 l1
|
||||
| Call(c0), Call(c1) ->
|
||||
Call.compare Proc.compare c0 c1
|
||||
| _ ->
|
||||
Pervasives.compare x y
|
||||
|
||||
let fmt ff tr =
|
||||
let fmt_blk ff blk =
|
||||
Format.fprintf ff "@[<hv>%a;@]" (List.fmt ";@ " I.fmt) blk
|
||||
in
|
||||
let fmt_blk_pos ff blk =
|
||||
let fmt_pos_inst ff {I.desc; pos} =
|
||||
Format.fprintf ff "@[<hov 2>%a:@ %a@]" Position.fmt pos I.fmt_desc desc in
|
||||
Format.fprintf ff "@[<v>%a;@]" (List.fmt ";@\n" fmt_pos_inst) blk
|
||||
in
|
||||
let fmt_assumes ff blk =
|
||||
fmt_blk ff (List.filter (fun {I.desc} -> match desc with I.Assume _ -> true | _ -> false) blk)
|
||||
in
|
||||
let aux leak b =
|
||||
match !Config.vTr with
|
||||
| 0 -> Format.fprintf ff "@[<hv>%( fmt %)@]" leak
|
||||
| 1 -> Format.fprintf ff "@[<hv>%( fmt %)%a@]" leak fmt_assumes b
|
||||
| 2 -> Format.fprintf ff "@[<hv>%( fmt %)%a@]" leak fmt_blk b
|
||||
| _ -> Format.fprintf ff "@[<hv>%( fmt %)%a@]" leak fmt_blk_pos b
|
||||
in
|
||||
match tr with
|
||||
| Intra(_,b,_,false) -> aux "" b
|
||||
| Intra(_,b,_,true) -> aux "LEAK@ " b
|
||||
| Call({Call.proc= {Proc.id; freturn}; areturn} as call) ->
|
||||
let fmt_ret ff =
|
||||
match freturn, areturn with
|
||||
| Some(freturn), Some(areturn) -> Format.fprintf ff "[%a/%a] =@ " Var.fmt areturn Var.fmt freturn
|
||||
| Some(freturn), None -> Format.fprintf ff "[_/%a] =@ " Var.fmt freturn
|
||||
| None , Some(areturn) -> Format.fprintf ff "[%a/_] =@ " Var.fmt areturn
|
||||
| _ -> ()
|
||||
in
|
||||
let frmls_to_actls,_ = Call.args {call with Call.areturn= None} in
|
||||
Format.fprintf ff "@[<hov 2>%t@,@[%a(@[%a@])@]@]" fmt_ret Proc.Id.fmt id S.fmt frmls_to_actls
|
||||
| Return -> Format.fprintf ff "return"
|
||||
| Summary -> Format.fprintf ff "summary"
|
||||
|
||||
end
|
||||
|
||||
|
||||
(*============================================================================
|
||||
States / Vertices
|
||||
============================================================================*)
|
||||
|
||||
module Idx = struct
|
||||
include K
|
||||
|
||||
let fmt ff k =
|
||||
Format.fprintf ff "%a: %a: %a: "
|
||||
Id.fmt (K.id k) Position.fmt (K.pos k) (Option.fmt "" K.fmt_sort) (K.sort k)
|
||||
end
|
||||
|
||||
|
||||
(** abstract transition system *)
|
||||
module ATS = struct
|
||||
include Graph.Make (Idx) (RD) (Tr)
|
||||
|
||||
|
||||
let concat_blocks g v0 =
|
||||
L.incf 10 "( concat_blocks" ; L.decf 10 ") concat_blocks" $>
|
||||
let visited = VertexISet.create ()
|
||||
in
|
||||
let collapse_pre_ok v w =
|
||||
match Idx.sort (index_of v) , Idx.sort (index_of w) with
|
||||
| _ , None
|
||||
| Some(K.Entry | K.Cut | K.Join), Some(K.Join | K.Fork)
|
||||
| Some(K.Return) , Some(K.Fork) -> not (RD.is_error (label_of w))
|
||||
|
||||
| Some(K.Return) , Some(K.Join)
|
||||
| _ , Some(K.Exit | K.Return | K.Cut)
|
||||
| None , Some(K.Join | K.Fork)
|
||||
| Some(K.Exit) , _
|
||||
| _ , Some(K.Entry) -> false
|
||||
|
||||
| Some(K.Fork) , _ -> failwith "only called when one succ"
|
||||
in
|
||||
let collapse_post_ok v w =
|
||||
match Idx.sort (index_of v) , Idx.sort (index_of w) with
|
||||
| None , _
|
||||
| Some(K.Join | K.Fork) , Some(K.Exit | K.Cut | K.Join)
|
||||
| Some(K.Fork) , Some(K.Return | K.Fork) -> not (RD.is_error (label_of w))
|
||||
|
||||
| Some(K.Join) , Some(K.Return | K.Fork)
|
||||
| Some(K.Entry | K.Return | K.Cut), _
|
||||
| Some(K.Join | K.Fork) , None
|
||||
| Some(K.Exit) , _
|
||||
| _ , Some(K.Entry) -> false
|
||||
in
|
||||
let concat_ok v w =
|
||||
Idx.sort (index_of v) = None
|
||||
&& not (RD.is_error (label_of w))
|
||||
in
|
||||
let rec start v =
|
||||
L.printf 10 "start: %a" Vertex.fmt v ;
|
||||
if not (VertexISet.mem visited v) then
|
||||
match successors v with
|
||||
| [(w, (Tr.Intra(_,[],_,false) as e))] when collapse_pre_ok v w ->
|
||||
collapse_edge_pre g v e w ;
|
||||
start v
|
||||
| succs ->
|
||||
VertexISet.add visited v ;
|
||||
List.iter (fun (w,e) -> continue v e w) succs
|
||||
and continue v e w =
|
||||
L.printf 10 "continue: @[%a@]@ @[%a@]@ @[%a@]" Vertex.fmt v Tr.fmt e Vertex.fmt w ;
|
||||
match successors w with
|
||||
| [] when collapse_post_ok v w ->
|
||||
(match e with
|
||||
| Tr.Intra(_,[],_,false) ->
|
||||
collapse_edge_post g v e w
|
||||
| _ -> ()
|
||||
)
|
||||
| [(x, (Tr.Intra(_,[],_,false) as f))] when collapse_post_ok w x ->
|
||||
collapse_edge_post g w f x ;
|
||||
continue v e x
|
||||
| [(x, f)] when concat_ok w x ->
|
||||
(match Tr.append e f with
|
||||
| Some(ef) ->
|
||||
L.printf 10 "@[appending@ @[%a@]@ to @[%a@]@]" Tr.fmt e Tr.fmt f ;
|
||||
add_edge g v ef x ;
|
||||
remove_edge g v e w ;
|
||||
remove_vertex g w ;
|
||||
continue v ef x
|
||||
| None ->
|
||||
start w
|
||||
)
|
||||
| _ ->
|
||||
start w
|
||||
in
|
||||
start v0
|
||||
|
||||
end
|
||||
|
||||
|
||||
module Vtx = struct
|
||||
include ATS.Vertex
|
||||
|
||||
type d_cp = RD.t
|
||||
|
||||
let cp v = ATS.index_of v
|
||||
let d v = ATS.label_of v
|
||||
let project v = (d v, cp v)
|
||||
|
||||
let fmt ff v = Format.fprintf ff "%a@ %a" Idx.fmt (cp v) RD.fmt (d v)
|
||||
end
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Interprocedural Domain
|
||||
============================================================================*)
|
||||
|
||||
module I_D_cp = Vtx
|
||||
|
||||
type i_d_cp = Vtx.t
|
||||
type d_bk = Vtx.t * (Vtx.d_cp * K.t)
|
||||
|
||||
|
||||
type r = {
|
||||
prog: Prog.t;
|
||||
ats: ATS.graph;
|
||||
heights: int Heights.t;
|
||||
mutable hit_limit: bool;
|
||||
d: RD.r;
|
||||
}
|
||||
|
||||
let ats {ats} = ats
|
||||
|
||||
let states_for {ats} k =
|
||||
ATS.vertices_for ats k
|
||||
|
||||
let errors {ats} =
|
||||
ATS.fold_vertices (fun v errs ->
|
||||
if RD.is_error (ATS.label_of v) then
|
||||
v :: errs
|
||||
else
|
||||
errs
|
||||
) ats []
|
||||
|
||||
let leaks {prog; ats} =
|
||||
let {Prog.main; procs} = prog in
|
||||
let {Proc.entry} = Proc.IdHMap.find procs main in
|
||||
ATS.fold_edges (fun _ z -> z) (fun (v,e,_) leaks ->
|
||||
match e with
|
||||
| Tr.Intra(_,_,_,true) -> v :: leaks
|
||||
| _ -> leaks
|
||||
) ats entry []
|
||||
|
||||
let hit_limit r = r.hit_limit
|
||||
|
||||
let dead {prog; ats} =
|
||||
let add {Proc.cfg; entry} unreachable =
|
||||
CFG.fold_edges (fun _ u -> u) (fun (_,c,_) unreached ->
|
||||
match c with
|
||||
| C.Inst({I.pos}) ->
|
||||
Positions.add (pos) unreached
|
||||
| C.Call _ | C.ICall _ ->
|
||||
unreached
|
||||
) cfg (CFG.index_of entry) unreachable
|
||||
in
|
||||
let rem_edg (_,tr,_) unreached =
|
||||
match tr with
|
||||
| Tr.Intra(k, blk, k', _) ->
|
||||
unreached |>
|
||||
Positions.remove (K.pos k) |>
|
||||
List.fold (fun {I.pos} unreached ->
|
||||
Positions.remove (pos) unreached
|
||||
) blk |>
|
||||
Positions.remove (K.pos k')
|
||||
| Tr.Call _ | Tr.Return | Tr.Summary ->
|
||||
unreached
|
||||
in
|
||||
let rem_dominated {Proc.cfg; entry} unreachable =
|
||||
let _,_,_, dominated_by = CFG.dominance_frontier cfg entry in
|
||||
CFG.fold_vertices (fun h unreachable ->
|
||||
if not (Positions.mem (K.pos h) unreachable) then unreachable
|
||||
else
|
||||
CFG.VertexISet.fold (fun k unreachable ->
|
||||
if Position.equal (K.pos h) (K.pos k) then unreachable
|
||||
else
|
||||
Positions.remove (K.pos k) unreachable
|
||||
) (dominated_by h) unreachable
|
||||
) cfg unreachable
|
||||
in
|
||||
Positions.empty |>
|
||||
Prog.fold_procs add prog |>
|
||||
ATS.fold_edges (fun _ u -> u) rem_edg ats (ATS.index_of (List.hd (ATS.roots ats))) |>
|
||||
Prog.fold_procs rem_dominated prog |>
|
||||
Positions.to_list
|
||||
|
||||
let write_ats name prog ats entry =
|
||||
let open Prog in let open Proc in
|
||||
let fn k =
|
||||
Option.map (fun p -> (Id.name p.id, fun ff -> Proc.fmt ff p)) (IdHMap.tryfind prog.procs (K.proc k))
|
||||
in
|
||||
Library.with_out (name^".ats.dot") (ATS.write_dot ats entry) ;
|
||||
Library.with_out (name^".part.ats.dot") (ATS.write_dot_partitioned fn ats [entry])
|
||||
|
||||
let create prog =
|
||||
let {Prog.main; procs} = prog in
|
||||
let {Proc.entry} = Proc.IdHMap.find procs main in
|
||||
let r = {
|
||||
prog;
|
||||
ats= ATS.create ();
|
||||
heights= Heights.create 31;
|
||||
hit_limit= false;
|
||||
d= RD.create prog;
|
||||
} in
|
||||
Pervasives.at_exit (fun()->
|
||||
if Config.write_ats then
|
||||
write_ats Config.testname prog r.ats entry
|
||||
);
|
||||
r
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Transition System Operations
|
||||
============================================================================*)
|
||||
|
||||
let add_vertex_for_state r cp d =
|
||||
(fun v ->
|
||||
L.printf 2 "@\n@[<hov 2>adding state: %a@]" Vtx.fmt v ;
|
||||
assert( RD.equal_entry (Vtx.d v) d ))
|
||||
<&
|
||||
ATS.add_vertex r.ats (cp, {d with RD.blk= []})
|
||||
|
||||
|
||||
let add_transition_to_vertex r prev prev_to_call msg call =
|
||||
L.printf 2 "@\n@[<hv 2>adding transition:@\n@[%a@]@ @[<hov 2>from@ %a@]@ @[<hov 2>to@ %s@,%a@]@]"
|
||||
Tr.fmt prev_to_call Vtx.fmt prev msg Vtx.fmt call ;
|
||||
assert(
|
||||
match prev_to_call with
|
||||
| Tr.Call _ | Tr.Return -> true
|
||||
| _ -> RD.is_error (Vtx.d call) || RD.equal_entry (Vtx.d prev) (Vtx.d call)
|
||||
);
|
||||
ATS.add_edge r.ats prev prev_to_call call
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Interproc Domain Operations
|
||||
============================================================================*)
|
||||
|
||||
let init r (init_d, init_cp) =
|
||||
let init = ATS.add_vertex r.ats (init_cp, init_d) in
|
||||
ATS.root_vertex r.ats init ;
|
||||
L.printf 2 "@[<hov 2>adding initial state %a@]" Vtx.fmt init ;
|
||||
init
|
||||
|
||||
|
||||
let now_covered r vtx = not (ATS.mem_vertex r.ats vtx)
|
||||
|
||||
|
||||
let remove_covered_by r new_vtx =
|
||||
let remove_if_covered old_vtx =
|
||||
let new_d = Vtx.d new_vtx in
|
||||
let old_d = Vtx.d old_vtx in
|
||||
if not (RD.equal old_d new_d) then
|
||||
if RD.below old_d new_d then (
|
||||
L.printf 2 "@\n@[<hv 2>removing %a@ now covered by@ %a@]" Vtx.fmt old_vtx RD.fmt new_d ;
|
||||
ATS.replace_vertex r.ats (fun x -> x) old_vtx new_vtx ;
|
||||
assert( RD.equal_entry (Vtx.d new_vtx) (Vtx.d old_vtx) )
|
||||
)
|
||||
in
|
||||
List.iter remove_if_covered
|
||||
(ATS.vertices_for r.ats (ATS.index_of new_vtx))
|
||||
|
||||
let join msg r (prev, (tr, next_d, next_cp)) =
|
||||
if Config.join_powerset then
|
||||
let trg = add_vertex_for_state r next_cp next_d in
|
||||
if (Config.join_reduce > 0 && (Some K.Cut) = (K.sort next_cp))
|
||||
|| (Config.join_reduce > 1 && (Some K.Join) = (K.sort next_cp))
|
||||
|| (Config.join_reduce > 2)
|
||||
then
|
||||
remove_covered_by r trg ;
|
||||
add_transition_to_vertex r prev tr msg trg ;
|
||||
trg
|
||||
else
|
||||
let trylookup_d r d =
|
||||
List.tryfind (fun v -> RD.equal_entry d (Vtx.d v))
|
||||
(ATS.vertices_for r.ats next_cp)
|
||||
in
|
||||
let trg =
|
||||
match trylookup_d r next_d with
|
||||
| None ->
|
||||
add_vertex_for_state r next_cp next_d
|
||||
| Some(old_vtx) ->
|
||||
let old_or_new = RD.join next_d (Vtx.d old_vtx) in
|
||||
let trg = add_vertex_for_state r next_cp old_or_new in
|
||||
ATS.replace_vertex r.ats (fun tr -> tr) old_vtx trg ;
|
||||
assert( RD.equal_entry (Vtx.d trg) (Vtx.d old_vtx) );
|
||||
trg
|
||||
in
|
||||
add_transition_to_vertex r prev tr msg trg ;
|
||||
trg
|
||||
|
||||
|
||||
let prev_to_join r (prev, (next_d, next_cp)) =
|
||||
join "join " r (prev, (Tr.Intra(Vtx.cp prev, List.rev next_d.RD.blk, next_cp, false), next_d, next_cp))
|
||||
|
||||
|
||||
type __covered = WasCoveredByOld | NowCoveredByNew
|
||||
|
||||
|
||||
let widen msg r (prev, (tr, next_d, next_cp)) =
|
||||
(* Note: this should be the below operation *)
|
||||
let covered_by r d =
|
||||
LSE.incf 5 "( covered_by: %a" RD.fmt d ;
|
||||
LSE.decf 5 ") covered_by: %a@\n" (Option.fmt "None" Vtx.fmt)
|
||||
<&
|
||||
let rec loop = function
|
||||
| [] -> None
|
||||
| v :: vs -> if RD.below d (Vtx.d v) then Some(v) else loop vs
|
||||
in
|
||||
loop (List.rev (ATS.vertices_for r.ats next_cp))
|
||||
in
|
||||
let generalize r d =
|
||||
let new_height =
|
||||
match Heights.tryfind r.heights next_cp with
|
||||
| Some(h) -> h + 1
|
||||
| None -> 1
|
||||
in
|
||||
Heights.add r.heights next_cp new_height
|
||||
;
|
||||
if Config.limit <= 0 || new_height <= Config.limit then
|
||||
RD.generalize d
|
||||
else (
|
||||
r.hit_limit <- true ;
|
||||
LSE.printf 1 "ascending chain too long for %a@\n" K.fmt next_cp ;
|
||||
(RD.join d RD.tt, true)
|
||||
)
|
||||
in
|
||||
match covered_by r next_d with
|
||||
| Some(trg) ->
|
||||
add_transition_to_vertex r prev tr "covering " trg ;
|
||||
(WasCoveredByOld, trg)
|
||||
| None ->
|
||||
let abs_d, junk = generalize r next_d in
|
||||
let trg =
|
||||
if not junk then
|
||||
join msg r (prev, (tr, abs_d, next_cp))
|
||||
else
|
||||
let leak = join msg r (prev, (tr, next_d, next_cp)) in
|
||||
LSE.printf 1 "LEAK detected@\n@\n" ;
|
||||
let leak_to_abs = Tr.Intra(Vtx.cp leak, [], next_cp, true) in
|
||||
join msg r (leak, (leak_to_abs, abs_d, next_cp))
|
||||
in
|
||||
(NowCoveredByNew, trg)
|
||||
|
||||
|
||||
let prev_to_cut r (prev, (next_d, next_cp)) =
|
||||
widen "new " r (prev, (Tr.Intra(Vtx.cp prev, List.rev next_d.RD.blk, next_cp, false), next_d, next_cp))
|
||||
|
||||
|
||||
(* Note: shouldn't this call to join be made by the fixed-point comp? *)
|
||||
let post_to_retn r call post_d_to_retn_d (post, (post_d, retn_cp)) =
|
||||
let retn_d = post_d_to_retn_d post_d
|
||||
in
|
||||
(* add exit to return transition *)
|
||||
let retn =
|
||||
if Config.generalize_call_retn
|
||||
then snd (widen "return " r (post, (Tr.Return, retn_d, retn_cp)))
|
||||
else join "return " r (post, (Tr.Return, retn_d, retn_cp))
|
||||
in
|
||||
add_transition_to_vertex r call Tr.Summary "summary " retn
|
||||
;
|
||||
retn
|
||||
|
||||
|
||||
let call_to_pre r call pcall pre =
|
||||
add_transition_to_vertex r call (Tr.Call(pcall)) "pre " pre
|
||||
|
||||
|
||||
let add_prev_to_call_to_pre r (prev, (call_d, call_cp)) pcall pre =
|
||||
(* add transition to call site *)
|
||||
let call =
|
||||
if K.equal (Vtx.cp prev) call_cp
|
||||
then prev
|
||||
else
|
||||
if Config.generalize_call_retn
|
||||
then snd (widen "call " r (prev, (Tr.Intra(Vtx.cp prev, List.rev call_d.RD.blk, call_cp, false), call_d, call_cp)))
|
||||
else join "call " r (prev, (Tr.Intra(Vtx.cp prev, List.rev call_d.RD.blk, call_cp, false), call_d, call_cp))
|
||||
in
|
||||
(* add call to pre transition *)
|
||||
call_to_pre r call pcall pre
|
||||
;
|
||||
call
|
||||
|
||||
|
||||
(* Note: the signature of this is wrong somehow, call_d can be projected out
|
||||
of call, and hist and call_cp are not needed *)
|
||||
let adapted_pre_substate_call r cxt pre ((_, (call_d, _)) as prev_to_call) pcall =
|
||||
match RD.adapted_pre_substate_call r.d cxt (Vtx.d pre) call_d pcall with
|
||||
| None -> None
|
||||
| Some(post_d_to_retn_d) ->
|
||||
(* add transition to call site *)
|
||||
let call = add_prev_to_call_to_pre r prev_to_call pcall pre
|
||||
in
|
||||
Some(post_to_retn r call post_d_to_retn_d)
|
||||
|
||||
|
||||
let call_to_entry r ((_, (call_d, _)) as prev_to_call) ({Call.proc= callee} as pcall) =
|
||||
let entry, post_d_to_retn_d = RD.call_to_entry r.d call_d pcall
|
||||
in
|
||||
let entry = add_vertex_for_state r callee.Proc.entry entry
|
||||
in
|
||||
(* PS#208: here we should instead check if entry with the ghosts
|
||||
existentially quantified is covered *)
|
||||
remove_covered_by r entry
|
||||
;
|
||||
(* add transition to call site *)
|
||||
let call = add_prev_to_call_to_pre r prev_to_call pcall entry
|
||||
in
|
||||
(entry, post_to_retn r call post_d_to_retn_d)
|
||||
|
||||
|
||||
let exit_to_retn callee (prev, (exit_d, retn_cp)) =
|
||||
(prev, (RD.exit_to_retn callee exit_d, retn_cp))
|
||||
|
||||
|
||||
let resolve_indirect_call r (_, (call_d, _)) fptr ftyp =
|
||||
RD.resolve_indirect_call r.d call_d fptr ftyp
|
||||
|
||||
|
||||
let procedure_pres r fn =
|
||||
(* PS#134: this doesn't necessarily yield reverse order of addition *)
|
||||
ATS.vertices_for r.ats fn.Proc.entry
|
||||
|
||||
|
||||
(* ensure that pre doesn't get GCed if it gets disconnected *)
|
||||
let register_pre r pre = ATS.root_vertex r.ats pre
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open Library
|
||||
|
||||
open Program
|
||||
open Interproc_sig
|
||||
|
||||
|
||||
module Domain (RD: RELATION_DOMAIN) : sig
|
||||
|
||||
module Tr : sig
|
||||
type t =
|
||||
| Intra of ControlPoint.t * Inst.t list * ControlPoint.t * bool
|
||||
| Call of Proc.t Call.t
|
||||
| Return
|
||||
| Summary
|
||||
|
||||
val append : t -> t -> t option
|
||||
val compare : t -> t -> int
|
||||
val equal : t -> t -> bool
|
||||
val fmt : t formatter
|
||||
end
|
||||
|
||||
module ATS : sig
|
||||
include
|
||||
(Graph.GRAPH
|
||||
with type index = ControlPoint.t
|
||||
and type e_label = Tr.t)
|
||||
|
||||
val concat_blocks : graph -> vertex -> unit
|
||||
end
|
||||
|
||||
include
|
||||
(INTERPROC_DOMAIN
|
||||
with type RD.t = ATS.v_label
|
||||
and type RD.pred = RD.pred
|
||||
and type I_D_cp.t = ATS.vertex)
|
||||
|
||||
val ats : r -> ATS.graph
|
||||
val write_ats : string -> Prog.t -> ATS.graph -> ATS.index -> unit
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,366 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Abstraction of symbolic heaps *)
|
||||
|
||||
(* Notes:
|
||||
- The definition of abs_junk effectively distributes every [_ * true] to the
|
||||
root of the formula. An alternative is to keep the [_ * true] subformulas
|
||||
in the *-\/ tree where the garbage they abstract came from. The second is
|
||||
logically stronger, but perhaps disturbing to the prover. Overall it is
|
||||
not clear which is preferable, there should be an option to use either
|
||||
technique.
|
||||
|
||||
- It seems that, since abstracted formulas only get weaker, it should be
|
||||
possible to normalize the formula to be abstracted just once at the
|
||||
beginning and then simply reuse the resulting congruence relation.
|
||||
*)
|
||||
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
module S = Substitution
|
||||
open SymbolicHeap
|
||||
open Program
|
||||
|
||||
(* lvl 1 = entry-point entry/exit and summary rewrite
|
||||
2 = individual abstraction rewrites
|
||||
3 = each abstraction rule entry/exit and summary rewrite
|
||||
> = subsidiary computations *)
|
||||
module L = (val Log.std Config.vAbs : Log.LOG)
|
||||
|
||||
|
||||
|
||||
(* Timing =================================================================== *)
|
||||
|
||||
let abstract_tmr = Timer.create "Abstraction.abstract"
|
||||
let abs_junk_tmr = Timer.create "Abstraction.abs_junk"
|
||||
let abs_ls_tmr = Timer.create "Abstraction.abs_ls"
|
||||
let abs_arith_tmr = Timer.create "Abstraction.abs_arith"
|
||||
let abs_pure_tmr = Timer.create "Abstraction.abs_pure"
|
||||
let normalize_tmr = Timer.create "Abstraction.SH.normalize"
|
||||
|
||||
|
||||
module XSH = struct include XSH
|
||||
let normalize xsh =
|
||||
Timer.start normalize_tmr ;
|
||||
let res = normalize xsh in
|
||||
Timer.stop normalize_tmr ;
|
||||
res
|
||||
end
|
||||
|
||||
|
||||
(* Formatting =============================================================== *)
|
||||
|
||||
let fmt_abs lvl msg (xs,sh) (xs',sh') =
|
||||
if lvl <= !Config.vAbs then
|
||||
let fmt_o, _fmt_i, fmt_n = SH.fmt_did_xs ((xs,sh), (xs',sh')) in
|
||||
L.printf lvl "@[<hov 2>%sreplace:@ %t@]@ @[<hov 2>with:@ %t@]" msg fmt_o fmt_n
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Abstract unreachable points-tos and list-segs.
|
||||
============================================================================*)
|
||||
|
||||
let abs_junk (xs,sh) =
|
||||
Timer.start abs_junk_tmr ;
|
||||
L.incf 3 "( abs_junk:@ %a" SH.fmt_xs (xs,sh) ;
|
||||
(fun xsho ->
|
||||
Timer.stop abs_junk_tmr ;
|
||||
Option.option () (fun (xs',sh') -> fmt_abs 2 "abs_junk: " (xs,sh) (xs', SH.Jnk.star sh')) xsho ;
|
||||
L.decf 3 ") abs_junk:@ %a" (Option.fmt "unchanged" SH.fmt_xs) xsho )
|
||||
<&
|
||||
let keep = (fun loc -> Vars.disjoint xs (E.fv loc))
|
||||
in
|
||||
let is_reachable = Reachability.is_reachable keep sh
|
||||
in
|
||||
let sh, pgs =
|
||||
SH.map_fold (fun sh pgs ->
|
||||
let sh, pgs =
|
||||
SH.PtS.fold (fun ({Pt.loc} as pt) (sh, pgs) ->
|
||||
if is_reachable sh loc then (sh, pgs)
|
||||
else (SH.PtS.remove pt sh, true)
|
||||
) sh (sh, pgs) in
|
||||
let sh, pgs =
|
||||
SH.LsS.fold (fun ls (sh, pgs) ->
|
||||
let loc = Ls.fst_alloc ls in
|
||||
if is_reachable sh loc then (sh, pgs)
|
||||
else (SH.LsS.remove ls sh, true)
|
||||
) sh (sh, pgs) in
|
||||
(sh, pgs)
|
||||
) sh false
|
||||
in
|
||||
if pgs then
|
||||
Some(xs,sh)
|
||||
else
|
||||
None
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Abstract lists.
|
||||
============================================================================*)
|
||||
|
||||
let abs_ls (xs,sh) =
|
||||
Timer.start abs_ls_tmr ;
|
||||
L.incf 3 "( abs_ls:@ %a" SH.fmt_xs (xs,sh) ;
|
||||
(fun xsho ->
|
||||
Timer.stop abs_ls_tmr ;
|
||||
L.decf 3 ") abs_ls:@ %a" (Option.fmt "unchanged" SH.fmt_xs) xsho )
|
||||
<&
|
||||
HeapAbstraction.abstract (xs,sh)
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Abstract arithmetic expressions.
|
||||
============================================================================*)
|
||||
|
||||
(* Keep integer program constants, as control flow often depends on them.
|
||||
(For instance, PS#146 documents the case of kdbclass.c using the constant
|
||||
NT_STATUS returned by IoCreateDevice.)
|
||||
*)
|
||||
let pgm_consts : unit Int64HMap.t = Int64HMap.create 31
|
||||
|
||||
let _ = Initialize.register (fun {Prog.constants} ->
|
||||
List.iter (fun i -> Int64HMap.add pgm_consts i ()) constants
|
||||
)
|
||||
|
||||
let pgm_const e =
|
||||
assert(true$> L.incf 8 "( pgm_const:@ %a" E.fmt e ); (fun b -> assert(true$> L.decf 8 ") pgm_const:@ %b" b )) <&
|
||||
match E.desc e with
|
||||
| E.Num(n) when (Int64HMap.mem pgm_consts n) -> true
|
||||
| _ -> false
|
||||
|
||||
|
||||
let abs_arith (xs,sh) =
|
||||
Timer.start abs_arith_tmr ;
|
||||
L.incf 3 "( abs_arith:@ %a" SH.fmt_xs (xs,sh) ;
|
||||
(fun xsho ->
|
||||
Timer.stop abs_arith_tmr ;
|
||||
Option.option () (fmt_abs 2 "abs_arith: " (xs,sh)) xsho ;
|
||||
L.decf 3 ") abs_arith:@ %a" (Option.fmt "unchanged" SH.fmt_xs) xsho )
|
||||
<&
|
||||
(* Abstract constant list lengths *)
|
||||
let sh, (pgs, fresh_vs) =
|
||||
SH.map_fold (fun sh (pgs,vs) ->
|
||||
let vs, lss, sh =
|
||||
SH.LsS.fold (fun ({Ls.len} as ls) (vs,lss,sh) ->
|
||||
match E.desc len with
|
||||
| E.Num _ ->
|
||||
let k = Var.gensym "a" Var.IntegerSort in
|
||||
( Vars.add k vs
|
||||
, {ls with Ls.len= E.mkVar k} :: lss
|
||||
, SH.LsS.remove ls sh )
|
||||
| _ ->
|
||||
(vs,lss,sh)
|
||||
) sh (vs, [], sh) in
|
||||
if lss = [] then (sh, (pgs, vs))
|
||||
else (SH.LsS.star lss sh, (true, vs))
|
||||
) sh (false, Vars.empty)
|
||||
in
|
||||
(* Abstract all integer constants except 0, 1, and those appearing in program *)
|
||||
let to_abstract e (s, fresh_vs) =
|
||||
if Config.preserve_consts && pgm_const e then (s, fresh_vs)
|
||||
else if S.in_dom e s then (s, fresh_vs)
|
||||
else match E.desc e with
|
||||
| E.Var _ | E.Num(0L) | E.Num(1L) -> (s, fresh_vs)
|
||||
| E.Op3(E.Ite,_,E.Num(1L),E.Num(0L)) -> (s, fresh_vs)
|
||||
| _ when E.sort_of e = Var.IntegerSort ->
|
||||
let f = Var.gensym "a" Var.IntegerSort in
|
||||
(S.add e (E.mkVar f) s, Vars.add f fresh_vs)
|
||||
| _ -> (s, fresh_vs)
|
||||
in
|
||||
let exp_subst, fresh_vs = SH.fold_exps to_abstract sh (S.empty, fresh_vs)
|
||||
in
|
||||
if not pgs && S.is_empty exp_subst then
|
||||
None
|
||||
else
|
||||
(* Note: change this SH.subst to preserve normalization *)
|
||||
let sh' = SH.subst exp_subst sh in
|
||||
Some(Vars.union fresh_vs xs, sh')
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Abstract Pure Formulas.
|
||||
============================================================================*)
|
||||
|
||||
let abs_pure (xs,sh) =
|
||||
Timer.start abs_pure_tmr ;
|
||||
L.incf 3 "( abs_pure:@ %a" SH.fmt_xs (xs,sh) ;
|
||||
(fun xsho ->
|
||||
Timer.stop abs_pure_tmr ;
|
||||
Option.option () (fmt_abs 2 "abs_pure: " (xs,sh)) xsho ;
|
||||
L.decf 3 ") abs_pure:@ %a" (Option.fmt "unchanged" SH.fmt_xs) xsho )
|
||||
<&
|
||||
|
||||
let pgs = ref false in
|
||||
|
||||
let kills = Vars.diff xs (SH.fv (SH.spatial_sf sh)) in
|
||||
|
||||
L.printf 6 "kills: @[<hov 1>{%a}@]" Vars.fmt kills ;
|
||||
|
||||
if Vars.is_empty kills then None else
|
||||
|
||||
let abs_pure_q q _ =
|
||||
(* L.incf 6 "( abs_pure_q:@ %a" SH.fmt q ; (fun (q',_) -> L.decf 6 ") abs_pure_q:@ %a" SH.fmt q' ) <& *)
|
||||
(* convert the classes to a list of equalities between not killable exps *)
|
||||
let classes = SH.Pf.classes q in
|
||||
let eqs =
|
||||
Expss.fold (fun cls eqs ->
|
||||
L.printf 6 "cls: %a" Exps.fmt cls ;
|
||||
if Exps.cardinal cls <= 1 then eqs
|
||||
else
|
||||
(* filter the killable exps out of the class *)
|
||||
let filtered_cls =
|
||||
Exps.fold (fun e filtered_cls ->
|
||||
let fv_e = Exp.fv e in
|
||||
if Vars.disjoint fv_e kills
|
||||
then filtered_cls
|
||||
else
|
||||
let filtered_cls' = Exps.remove e filtered_cls in
|
||||
pgs := true ;
|
||||
L.printf 6 "abs_pure: %a" E.fmt e ;
|
||||
filtered_cls'
|
||||
) cls cls in
|
||||
if Exps.cardinal filtered_cls <= 1 then eqs
|
||||
else
|
||||
(* convert the filtered class to a list of equalities *)
|
||||
let x = Exps.choose filtered_cls in
|
||||
let xs = Exps.remove x filtered_cls in
|
||||
let rec aux xs =
|
||||
if Exps.is_empty xs then
|
||||
eqs
|
||||
else
|
||||
let y = Exps.choose xs in
|
||||
let ys = Exps.remove y xs in
|
||||
E.mkEq x y :: aux ys in
|
||||
(* add killed exps to subst *)
|
||||
aux xs
|
||||
) classes []
|
||||
in
|
||||
(* L.printf 5 "eqs_pgs: %b" !pgs ; *)
|
||||
(* L.printf 5 "eqs: %a" (List.fmt ";@ " E.fmt) eqs ; *)
|
||||
(* remove any boolean exp containing a kill *)
|
||||
let bex = SH.Pf.term q in
|
||||
(* L.incf 5 "( remove: %a" E.fmt bex ; *)
|
||||
let bex' =
|
||||
E.remove (fun d ->
|
||||
if Vars.disjoint (E.fv (E.name d)) kills then false
|
||||
else (
|
||||
pgs := true ;
|
||||
true
|
||||
)
|
||||
) bex in
|
||||
(* L.decf 5 ") remove: %a" E.fmt bex' ; *)
|
||||
(* conjoin the abstracted boolean expression and filtered equalities *)
|
||||
(* Note: change this SH.Pf.empty to preserve normalization *)
|
||||
let q' = SH.Pf.star (bex' :: eqs) (SH.Pf.empty q) in
|
||||
(* remove pure disjunctions *)
|
||||
let q' =
|
||||
SH.DjS.filter (fun dj ->
|
||||
if Dj.for_all SH.is_empty dj then (
|
||||
pgs := true ;
|
||||
false
|
||||
) else
|
||||
true
|
||||
) q' in
|
||||
(q', !pgs)
|
||||
in
|
||||
let sh', pgs =
|
||||
SH.map_fold abs_pure_q sh false
|
||||
in
|
||||
if pgs then Some(xs,sh') else None
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Entry Point.
|
||||
============================================================================*)
|
||||
|
||||
let gen_query id xsh =
|
||||
TestGen.gen ("abs_" ^ (string_of_int id)) (fun ff ->
|
||||
Format.fprintf ff
|
||||
"let tmr = Timer.create() in Timer.start tmr ;@\n\
|
||||
@\n@[<hov 3>(* abstract:@ %a@]@\n*)@\n\
|
||||
@[<hov 2>Abstraction.abstract@\n%a@] |> ignore;@\n\
|
||||
Timer.stop Timer.init ;@\n\
|
||||
Statistics.report (Timer.create()) tmr (Timer.create())"
|
||||
XSH.fmt xsh
|
||||
XSH.fmt_caml xsh
|
||||
)
|
||||
|
||||
|
||||
let new_query =
|
||||
let count = ref 0
|
||||
in
|
||||
fun xsh ->
|
||||
incr count;
|
||||
if !count = Config.abs_query_to_gen then gen_query !count xsh;
|
||||
!count
|
||||
|
||||
|
||||
let seq f g x = g (Option.from_option x (f x))
|
||||
|
||||
let fix f x =
|
||||
match f x with
|
||||
| None -> None
|
||||
| Some(x') ->
|
||||
let rec loop x =
|
||||
match f x with
|
||||
| None -> Some(x)
|
||||
| Some(x') -> loop x' in
|
||||
loop x'
|
||||
|
||||
|
||||
let abstract xsh =
|
||||
Timer.start abstract_tmr ;
|
||||
let xsh = XSH.normalize xsh in
|
||||
|
||||
let query = new_query xsh in
|
||||
L.incf 1 "( abstract %d:@ %a" query XSH.fmt xsh ;
|
||||
|
||||
if XSH.inconsistent xsh then
|
||||
(XSH.ff, false)
|
||||
else
|
||||
|
||||
let junk = ref false in
|
||||
let abs_junk x =
|
||||
let xo = abs_junk x in
|
||||
match xo with
|
||||
| Some _ -> junk := true; xo
|
||||
| None -> xo
|
||||
in
|
||||
|
||||
let abs =
|
||||
(seq abs_ls
|
||||
(seq abs_junk
|
||||
(seq (fix abs_arith)
|
||||
(seq abs_pure
|
||||
id
|
||||
)))) in
|
||||
|
||||
let xs, sh = XSH.exists_bind Vars.empty xsh in
|
||||
|
||||
let xs',sh' = abs (xs, sh) in
|
||||
let sh' = if !junk then SH.Jnk.star sh' else sh' in
|
||||
|
||||
let xsh' = SH.exists_intro xs' sh' in
|
||||
|
||||
if not (SH.equal sh sh') then (
|
||||
fmt_abs 1 "" (xs,sh) (xs',sh') ;
|
||||
L.decf 1 ") abstract:@ %a@\n" XSH.fmt xsh'
|
||||
) else
|
||||
L.decf 1 ") abstract:@ unchanged@\n" ;
|
||||
|
||||
Timer.stop abstract_tmr ;
|
||||
assert( not Config.check_abs || (
|
||||
L.printf 6 "checking abstraction" ;
|
||||
Prover.entailsx xsh xsh' <> None
|
||||
|| (gen_query query xsh ; failwithf "Abstraction not provably sound" )
|
||||
));
|
||||
|
||||
(xsh', !junk)
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Abstraction of symbolic heaps *)
|
||||
|
||||
open SymbolicHeap
|
||||
|
||||
|
||||
val abstract_tmr : Timer.t
|
||||
val abs_junk_tmr : Timer.t
|
||||
val abs_ls_tmr : Timer.t
|
||||
val abs_arith_tmr : Timer.t
|
||||
val abs_pure_tmr : Timer.t
|
||||
val normalize_tmr : Timer.t
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Abstraction
|
||||
============================================================================*)
|
||||
|
||||
(** [abstract xsh] applies heuristics to abstract un-needed
|
||||
pure predicate, arithmetic, ls, dis-equality and points-to
|
||||
expressions. *)
|
||||
val abstract : XSH.t -> XSH.t * bool
|
||||
|
|
@ -0,0 +1,101 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Link the abstract domain and analysis algorithm together *)
|
||||
|
||||
(**/**)
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
module S = Substitution
|
||||
open Program
|
||||
module I = Inst
|
||||
module C = Cmnd
|
||||
module K = ControlPoint
|
||||
open SymbolicHeap
|
||||
(**/**)
|
||||
|
||||
module L = (val Log.std Config.vATS : Log.LOG)
|
||||
|
||||
|
||||
module SymbolicHeapsDomain = struct
|
||||
|
||||
include SymbolicExecution
|
||||
|
||||
let fmt_pre ff (sh,proc) =
|
||||
let ghosts =
|
||||
Vars.diff
|
||||
(Option.option Vars.empty XSH.fv sh)
|
||||
(Vars.union (Vars.of_list proc.Proc.formals) proc.Proc.modifs) in
|
||||
Format.fprintf ff "@[<hv>%a%a@]"
|
||||
(Vars.fmt_embrace "@[<hov 2>! " " .@]@ ") ghosts fmt sh
|
||||
|
||||
let error = None
|
||||
|
||||
let tt = Some(XSH.tt)
|
||||
|
||||
let is_error x = x = None
|
||||
|
||||
let is_false = function
|
||||
| Some(q) when XSH.equal q XSH.ff -> true
|
||||
| _ -> false
|
||||
|
||||
let join p q =
|
||||
match p, q with
|
||||
| Some(p), Some(q) -> Some(XSH.disj [p] q)
|
||||
| _ -> None
|
||||
|
||||
let generalize = function
|
||||
| None ->
|
||||
(None, false)
|
||||
| Some(q) ->
|
||||
let p, j = Abstraction.abstract q in
|
||||
(Some(p), j)
|
||||
|
||||
let below p q =
|
||||
match p, q with
|
||||
| _, None -> true
|
||||
| None, _ -> false
|
||||
| Some(p), Some(q) -> None <> Prover.entailsx p q
|
||||
|
||||
end
|
||||
|
||||
module Pair = Interproc.Pair(SymbolicHeapsDomain)
|
||||
module InterprocDomain = AbstractTransitionSystem.Domain(Pair)
|
||||
module RD = InterprocDomain.RD
|
||||
|
||||
include Interproc.Make (InterprocDomain)
|
||||
|
||||
module VertexSet = Set.Make(InterprocDomain.I_D_cp)
|
||||
|
||||
let init _prog = Some(XSH.emp)
|
||||
|
||||
let safe results = results.safe
|
||||
|
||||
let errors results = InterprocDomain.errors results.invariants
|
||||
|
||||
let leaks results =
|
||||
let {Prog.main; procs} = results.program in
|
||||
let {Proc.exit} = Proc.IdHMap.find procs main
|
||||
in
|
||||
VertexSet.of_list (InterprocDomain.leaks results.invariants)
|
||||
|>
|
||||
List.fold (fun v leaks ->
|
||||
match RD.project (fst (InterprocDomain.I_D_cp.project v)) with
|
||||
| Some(xsh) when not (XSH.is_empty (XSH.Jnk.remove xsh)) -> VertexSet.add v leaks
|
||||
| _ -> leaks
|
||||
) (InterprocDomain.states_for results.invariants exit)
|
||||
|>
|
||||
VertexSet.to_list
|
||||
|
||||
let must_diverge results =
|
||||
results.safe
|
||||
&&
|
||||
let {Prog.main; procs} = results.program in
|
||||
let {Proc.exit} = Proc.IdHMap.find procs main in
|
||||
(InterprocDomain.states_for results.invariants exit) = []
|
||||
|
||||
let dead results = InterprocDomain.dead results.invariants
|
||||
|
||||
let hit_limit results = results.hit_limit || InterprocDomain.hit_limit results.invariants
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Link the abstract domain and analysis algorithm together *)
|
||||
|
||||
(**/**)
|
||||
open Program
|
||||
open SymbolicHeap
|
||||
open Interproc_sig
|
||||
(**/**)
|
||||
|
||||
|
||||
module SymbolicHeapsDomain : (INTRAPROC_DOMAIN with type t = XSH.t option)
|
||||
|
||||
module Pair : (module type of Interproc.Pair(SymbolicHeapsDomain))
|
||||
|
||||
module InterprocDomain : (module type of AbstractTransitionSystem.Domain(Pair))
|
||||
|
||||
(* Analyze *)
|
||||
include (module type of Interproc.Make(InterprocDomain))
|
||||
|
||||
val init : Prog.t -> SymbolicHeapsDomain.t
|
||||
val exec_prog : Prog.t -> SymbolicHeapsDomain.t -> t
|
||||
|
||||
(* Query analysis result *)
|
||||
val safe : t -> bool
|
||||
val errors : t -> InterprocDomain.I_D_cp.t list
|
||||
val leaks : t -> InterprocDomain.I_D_cp.t list
|
||||
val must_diverge : t -> bool
|
||||
val dead : t -> Position.t list
|
||||
val hit_limit : t -> bool
|
||||
|
|
@ -0,0 +1,177 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Labeled bi-directional multi-edges *)
|
||||
|
||||
open Library
|
||||
open Variable
|
||||
|
||||
open SYMBOLIC_HEAP
|
||||
|
||||
|
||||
module Poly = struct
|
||||
|
||||
(* traversals *)
|
||||
|
||||
let map fn {prev; frnt; back; next} =
|
||||
let prev = List.map fn prev in
|
||||
let frnt = List.map fn frnt in
|
||||
let back = List.map fn back in
|
||||
let next = List.map fn next in
|
||||
{prev; frnt; back; next}
|
||||
|
||||
let map2 fn x y =
|
||||
let prev = List.map2 fn x.prev y.prev in
|
||||
let frnt = List.map2 fn x.frnt y.frnt in
|
||||
let back = List.map2 fn x.back y.back in
|
||||
let next = List.map2 fn x.next y.next in
|
||||
{prev; frnt; back; next}
|
||||
|
||||
let fold fn x z =
|
||||
List.fold fn x.prev
|
||||
(List.fold fn x.frnt
|
||||
(List.fold fn x.back
|
||||
(List.fold fn x.next
|
||||
z)))
|
||||
|
||||
let fold2 fn x y z =
|
||||
List.fold2 fn x.prev y.prev
|
||||
(List.fold2 fn x.frnt y.frnt
|
||||
(List.fold2 fn x.back y.back
|
||||
(List.fold2 fn x.next y.next
|
||||
z)))
|
||||
|
||||
let fold_links fn {prev; frnt; back; next} z =
|
||||
let rec fold_links_ xs ys z =
|
||||
match xs, ys with
|
||||
| x::xs, y::ys -> fold_links_ xs ys (fn (x,y) z)
|
||||
| _ -> z
|
||||
in
|
||||
fold_links_ back prev (fold_links_ frnt next z)
|
||||
|
||||
let fold_links2 fn x y z =
|
||||
let rec fold_links2_ vs ws xs ys z =
|
||||
match vs, ws, xs, ys with
|
||||
| v::vs, w::ws, x::xs, y::ys ->
|
||||
fold_links2_ vs ws xs ys (fn (v,w) (x,y) z)
|
||||
| _ ->
|
||||
z
|
||||
in
|
||||
fold_links2_ x.back x.prev y.back y.prev
|
||||
(fold_links2_ x.frnt x.next y.frnt y.next
|
||||
z)
|
||||
|
||||
|
||||
let may_allocs {frnt; back} =
|
||||
List.rev_append back frnt
|
||||
|
||||
|
||||
(* constructors *)
|
||||
|
||||
(** [reverse] [p,f,b,n] = [n,b,f,p] *)
|
||||
(* let reverse {prev= p; frnt= f; back= b; next= n} *)
|
||||
(* = {prev= n; frnt= b; back= f; next= p} *)
|
||||
|
||||
|
||||
(** [between] [s, t;t', u, v;v'] [w, x;x', y, z;z']
|
||||
= [u, v;v', w, x;x'] *)
|
||||
let between
|
||||
{prev=_s; frnt=_t; back= u; next= v} {prev= w; frnt= x; back=_y; next=_z}
|
||||
= {prev= u; frnt= v; back= w; next= x}
|
||||
|
||||
|
||||
(** [append] [p, f;f', i, j;j'] [k, l;l', b, n;n']
|
||||
= [p, f;f', b, n;n'] *)
|
||||
(* Note: Check that args are adjacent? *)
|
||||
let append
|
||||
{prev= p; frnt= f; back=_i; next=_j} {prev=_k; frnt=_l; back= b; next= n}
|
||||
= {prev= p; frnt= f; back= b; next= n}
|
||||
|
||||
|
||||
(** [split w x u_v_y_z] returns [(u_v_w_x, w_x_y_z)] such that
|
||||
[u_v_y_z = append (append u_v_w_x w_x_w_x) w_x_y_z] where
|
||||
[w_x_w_x] is the empty segment determined by [x] and [w]. *)
|
||||
let split w x
|
||||
{prev= u; frnt= v; back= y; next= z} =
|
||||
({prev= u; frnt= v; back= w; next= x},
|
||||
{prev= w; frnt= x; back= y; next= z})
|
||||
|
||||
|
||||
(** [remove_prefix wy xz = (wx, yz)] such that if [wx] is empty, then
|
||||
[append wy yz = xz]. *)
|
||||
let remove_prefix
|
||||
{prev=s; frnt=t; back=u; next=v}
|
||||
{prev=w; frnt=x; back=y; next=z} =
|
||||
({prev=s; frnt=t; back=w; next=x}, {prev=u; frnt=v; back=y; next=z})
|
||||
|
||||
|
||||
(** [remove_suffix xz wy = (yz, wx)] such that if [yz] is empty, then
|
||||
[append wx xz = wy]. *)
|
||||
let remove_suffix xz wy =
|
||||
let wx, yz = remove_prefix wy xz in
|
||||
(yz, wx)
|
||||
|
||||
end
|
||||
|
||||
|
||||
module Make (A: TERM) = struct
|
||||
|
||||
include Poly
|
||||
|
||||
type a = A.t
|
||||
type t = a edg
|
||||
|
||||
|
||||
(** [adjacent x y] holds if [x] and [y] are adjacent. Eg:
|
||||
[adjacent] [p, f;f', i, j]
|
||||
[k, l;l', b, n;n']
|
||||
holds if i = k & j = l *)
|
||||
(* let rec adjacent x y = *)
|
||||
(* match x.next, y.frnt with *)
|
||||
(* | n::next, f::frnt -> A.equal n f && adjacent {x with next} {y with frnt} *)
|
||||
(* | _ -> *)
|
||||
(* match y.prev, x.back with *)
|
||||
(* | p::prev, b::back -> A.equal p b && adjacent {x with back} {y with prev} *)
|
||||
(* | _ -> *)
|
||||
(* true *)
|
||||
|
||||
|
||||
let fv x =
|
||||
fold (fun a z -> Vars.union (A.fv a) z) x Vars.empty
|
||||
|
||||
let map_exps fn x =
|
||||
map (fun a -> A.map_exps fn a) x
|
||||
|
||||
let fold_exps fn x z =
|
||||
fold (fun a z -> A.fold_exps fn a z) x z
|
||||
|
||||
let equal x y =
|
||||
List.equal A.equal x.prev y.prev
|
||||
&& List.equal A.equal x.frnt y.frnt
|
||||
&& List.equal A.equal x.back y.back
|
||||
&& List.equal A.equal x.next y.next
|
||||
|
||||
let compare x y =
|
||||
let o = List.compare A.compare x.frnt y.frnt in if o <> 0 then o else
|
||||
let o = List.compare A.compare x.back y.back in if o <> 0 then o else
|
||||
let o = List.compare A.compare x.prev y.prev in if o <> 0 then o else
|
||||
List.compare A.compare x.next y.next
|
||||
|
||||
(** We write [p;p', f;f', b;b', n;n'] for
|
||||
[\{fore= \[(f,n);(f',n')\]; back= \[(b,p);(b',p')\]\}] *)
|
||||
let fmtp fxt ff {prev; frnt; back; next} =
|
||||
let fmtl f = List.fmt ";@ " f in
|
||||
Format.fprintf ff
|
||||
"@[<hv>@[<hv>@[%a@],@ @[%a@]@],@ @[<hv>@[%a@],@ @[%a@]@]@]"
|
||||
(fmtl (A.fmtp fxt)) prev (fmtl (A.fmtp fxt)) frnt
|
||||
(fmtl (A.fmtp fxt)) back (fmtl (A.fmtp fxt)) next
|
||||
|
||||
let fmt ff x = fmtp (Vars.empty,Vars.empty) ff x
|
||||
|
||||
let fmt_caml ff {prev; frnt; back; next} =
|
||||
Format.fprintf ff
|
||||
"@[{BiEdge.Poly.@,\
|
||||
prev= [@[%a@]];@ frnt= [@[%a@]];@ back= [@[%a@]];@ next= [@[%a@]]}@]"
|
||||
(List.fmt ";@ " A.fmt_caml) prev (List.fmt ";@ " A.fmt_caml) frnt
|
||||
(List.fmt ";@ " A.fmt_caml) back (List.fmt ";@ " A.fmt_caml) next
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Labeled bi-directional multi-edges *)
|
||||
|
||||
open SYMBOLIC_HEAP
|
||||
|
||||
|
||||
module Poly : POLY_BIEDGE
|
||||
|
||||
|
||||
module Make (A: TERM) : (BIEDGE with type a = A.t)
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
module type CONGRUENCE_RELATION = sig
|
||||
|
||||
type exp
|
||||
(** Exps. *)
|
||||
|
||||
type exps
|
||||
(** Sets of exps. *)
|
||||
|
||||
type t
|
||||
(** A congruence relation representation [r: t] denotes a relation [[r]]
|
||||
over a finite 'carrier' set of exps that is a congruence with respect
|
||||
to the subexp relation. *)
|
||||
|
||||
val normalize : t -> exp -> exp
|
||||
(** [normalize r (normalize r e)] = [normalize r e] and [normalize r e] =
|
||||
[normalize r f] iff ([e],[f]) is in [[r]]. *)
|
||||
|
||||
val mem : t -> exp -> exp -> bool
|
||||
(** [mem r e f] test if [r] proves [e]==[f]. *)
|
||||
|
||||
val mem_dqs : t -> exp -> exp -> bool
|
||||
(** [mem_dqs r e f] test if [r] proves [e]!=[f]. *)
|
||||
|
||||
val inconsistent : t -> bool
|
||||
(** [inconsistent r] holds only if [r] is inconsistent. *)
|
||||
|
||||
val class_of : t -> exp -> exps
|
||||
(** [f] in [class_of r e] iff ([e],[f]) in [[r]]. *)
|
||||
|
||||
val mem_carrier : exp -> t -> bool
|
||||
(** [mem_carrier e r] holds iff [e] is in the carrier of [r]. *)
|
||||
|
||||
val carrier : t -> exps
|
||||
(** [e] in [carrier r] iff [e] is in the carrier of [r]. *)
|
||||
|
||||
val representatives : t -> exps
|
||||
(** [e'] in [representatives r] iff [normalize r e'] = [e']. *)
|
||||
|
||||
val fold : (exp -> exp -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
(** [fold fn r] enumerates the equations in [r]. The representative is
|
||||
passed to [fn] first. *)
|
||||
|
||||
val foldn : (exp -> exp -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
(** [foldn fn r] enumerates the disequations in [r]. *)
|
||||
|
||||
val fold_classes : (exp -> exps -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
(** [fold_classes fn r] enumerates the equivalence classes of [r]. *)
|
||||
|
||||
val empty : t
|
||||
(** [[empty]] is the empty relation. *)
|
||||
|
||||
val merge : (exp -> exp -> bool) -> t -> exp -> exp -> t
|
||||
(* Note: specify *)
|
||||
|
||||
val split : t -> exp -> exp -> t
|
||||
|
||||
val union : (exp -> exp -> bool) -> t -> t -> t
|
||||
(** [[union leq p q]] = [[r]] is the strongest congruence relation
|
||||
containing [[p]] and [[q]]. [union leq p q] maintains the
|
||||
representatives of [p] and chooses between them using [leq]: for [leq]
|
||||
a preorder, and for [normalize q e] = [f] then if [leq f e] then
|
||||
[normalize r e] = [normalize p f] else [normalize r f] = [normalize p
|
||||
e]. *)
|
||||
|
||||
val inter : (exp -> exp -> bool) -> t -> t -> t
|
||||
(** [[inter q r]] is the intersection of [[q]] and [[r]]. Smaller wrt
|
||||
[leq] representatives are chosen where possible. *)
|
||||
|
||||
val subst : (exp -> exp -> bool) -> t -> Substitution.t -> t
|
||||
(* Note: specify *)
|
||||
|
||||
val restrict : t -> exps -> t
|
||||
(** For [es] a superset of the representatives of [r], [normalize
|
||||
(restrict r es) e] = [normalize r e] if [e] in [es]. *)
|
||||
|
||||
val remove_trivial : t -> exps -> t
|
||||
(** [normalize (remove_trivial r es) e] = [normalize r e] if [e] in [es] and [class_of r e] is only [e]
|
||||
itseslf. [carrier (remove_trivial r es)] is the subset of [carrier r] excluding such expressions. *)
|
||||
|
||||
val implied_by : (exp -> exp -> bool) -> t -> Pure.t -> exp array -> exps -> t
|
||||
|
||||
val is_empty : t -> bool
|
||||
|
||||
val fmt : t formatter
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,836 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Congruence-closed relations *)
|
||||
|
||||
(* Notes:
|
||||
- It is possible for use lists to contain redundant equations. This might
|
||||
slow down propagation, but detecting and removing them might be more
|
||||
expensive.
|
||||
|
||||
- It is pointless to store use lists for offset exps, they are all
|
||||
distinct constants and so their use lists will never be looked up.
|
||||
|
||||
- Would representing classes as lists instead of sets be more efficient?
|
||||
|
||||
- Would separating cls_use into two maps be more efficient? The cost would
|
||||
be two more finds in propagate1, the benefit would be eliminating the
|
||||
Cls-Use pairs and reduced domain size of the use map.
|
||||
*)
|
||||
|
||||
open Library
|
||||
|
||||
(* open FORMULA *)
|
||||
(* open CONGRUENCE_RELATION *)
|
||||
module S = Substitution
|
||||
|
||||
module L = (val Log.std Config.vCng : Log.LOG)
|
||||
|
||||
|
||||
open Variable
|
||||
open Expression
|
||||
(* Either open Expression or use functor to reduce dependencies, also see EOF *)
|
||||
(* module Make *)
|
||||
(* (Exp: EXP) *)
|
||||
(* (Exps: Set.S with type elt = Exp.t) *)
|
||||
(* (ExpMap: Map.S with type key = Exp.t) *)
|
||||
(* : *)
|
||||
(* (CONGRUENCE_RELATION with type exp := Exp.t and type exps := Exps.t) = *)
|
||||
(* struct *)
|
||||
|
||||
(* module Exps = struct *)
|
||||
(* include Exps *)
|
||||
(* let fmt ff es = (List.fmt ",@ " Exp.fmt) ff (to_list es) *)
|
||||
(* end *)
|
||||
|
||||
|
||||
(* Class lists ============================================================== *)
|
||||
|
||||
module type CLS = sig
|
||||
type t
|
||||
val mem : Exp.t -> t -> bool
|
||||
val fold : (Exp.t -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val iter : (Exp.t -> unit) -> t -> unit
|
||||
val to_set : t -> Exps.t
|
||||
val add : Exp.t -> t -> t
|
||||
val remove : Exp.t -> t -> t
|
||||
val is_empty : t -> bool
|
||||
val singleton : Exp.t -> t
|
||||
val union : t -> t -> t
|
||||
val inter : Exps.t -> t -> t
|
||||
val fmt : t formatter
|
||||
end
|
||||
|
||||
module Cls : CLS = struct
|
||||
include Exps
|
||||
let to_set x = x
|
||||
let fmt ff x = Format.fprintf ff "@[<hov 1>{@[%a@]}@]" fmt x
|
||||
end
|
||||
|
||||
|
||||
(* Disequality lists ======================================================== *)
|
||||
|
||||
module type DQS = sig
|
||||
type t
|
||||
val mem : Exp.t -> t -> bool
|
||||
val fold : (Exp.t -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val iter : (Exp.t -> unit) -> t -> unit
|
||||
val add : Exp.t -> t -> t
|
||||
val empty : t
|
||||
val is_empty : t -> bool
|
||||
val union : t -> t -> t
|
||||
val inter : Exps.t -> t -> t
|
||||
val fmt : t formatter
|
||||
end
|
||||
|
||||
module Dqs : DQS = struct
|
||||
include Exps
|
||||
let fmt ff x = Format.fprintf ff "@[<hov 1>{@[%a@]}@]" fmt x
|
||||
end
|
||||
|
||||
|
||||
(* Use lists / Super-expression equations =================================== *)
|
||||
|
||||
module type USE = sig
|
||||
type t
|
||||
val empty : t
|
||||
val is_empty : t -> bool
|
||||
val add : Exp.t * Exp.t * Exp.t -> t -> t
|
||||
val iter : (Exp.t * Exp.t * Exp.t -> unit) -> t -> unit
|
||||
val fold : (Exp.t * Exp.t * Exp.t -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val exists : (Exp.t * Exp.t * Exp.t -> bool) -> t -> bool
|
||||
val union : t -> t -> t
|
||||
val fmt : t formatter
|
||||
end
|
||||
|
||||
(* Represents f(a)==c as App(App(f,a),c), and uses sets of such exps. *)
|
||||
module Use0 : USE = struct
|
||||
type t = Exps.t
|
||||
|
||||
let inj (f,a,c) = Exp.mkApp (Exp.mkApp f a) c
|
||||
let prj fac =
|
||||
let fa, c = Option.from_some (Exp.getApp fac) in
|
||||
let f, a = Option.from_some (Exp.getApp fa) in
|
||||
(f,a,c)
|
||||
|
||||
let fold fn s z = Exps.fold (fun fac z -> fn (prj fac) z) s z
|
||||
let iter fn s = Exps.iter (fun fac -> fn (prj fac)) s
|
||||
let exists pd s = Exps.exists (fun fac -> pd (prj fac)) s
|
||||
let add fac s = Exps.add (inj fac) s
|
||||
let union s t = Exps.union s t
|
||||
let empty = Exps.empty
|
||||
let is_empty = Exps.is_empty
|
||||
|
||||
let fmt ff s =
|
||||
let fmt_eq ff fac =
|
||||
match Exp.getApp fac with
|
||||
| None ->
|
||||
Format.fprintf ff "@[%a@]" Exp.fmt fac
|
||||
| Some(fa,c) -> match Exp.getApp fa with
|
||||
| None ->
|
||||
Format.fprintf ff "@[%a = %a@]" Exp.fmt fa Exp.fmt c
|
||||
| Some(f,a) ->
|
||||
Format.fprintf ff "@[%a(%a) = %a@]" Exp.fmt f Exp.fmt a Exp.fmt c
|
||||
in
|
||||
Format.fprintf ff "@[<hov 1>{@[%a@]}@]" (List.fmt ",@ " fmt_eq) (Exps.to_list s)
|
||||
end
|
||||
|
||||
(* Represents f(a)==c as (f,a,c), and uses lists of such triples. *)
|
||||
module Use1 : USE = struct
|
||||
include List.Set(struct type t = Exp.t * Exp.t * Exp.t end)
|
||||
let union = List.rev_append
|
||||
let fmt ff l =
|
||||
let fmt_eq ff (f,a,c) =
|
||||
Format.fprintf ff "@[%a(%a) = %a@]" Exp.fmt f Exp.fmt a Exp.fmt c in
|
||||
Format.fprintf ff "@[<hov 1>[@[%a@]]@]" (List.fmt ",@ " fmt_eq) l
|
||||
end
|
||||
|
||||
(* Represents f(a)==c as (f,a,c), and uses sets of such triples. *)
|
||||
module Use2 : USE = struct
|
||||
include Set.Make(struct
|
||||
type t = Exp.t * Exp.t * Exp.t
|
||||
|
||||
let equal (u,v,w) (x,y,z) =
|
||||
Exp.equal u x && Exp.equal v y && Exp.equal w z
|
||||
|
||||
let compare (u,v,w) (x,y,z) =
|
||||
let c = Exp.compare u x in if c <> 0 then c else
|
||||
let c = Exp.compare v y in if c <> 0 then c else
|
||||
Exp.compare w z
|
||||
end)
|
||||
let fmt _ = failwith "Use2.fmt unimplemented"
|
||||
end
|
||||
|
||||
(* Note: remove other implementations *)
|
||||
module Use = Use1
|
||||
|
||||
|
||||
(* Congruence relations ===================================================== *)
|
||||
|
||||
type t = {
|
||||
sat: bool;
|
||||
rep: Exp.t ExpMap.t;
|
||||
(** maps each expression in carrier to its representative *)
|
||||
cls_use: (Cls.t * Use.t * Dqs.t) ExpMap.t;
|
||||
(** maps each representative to the expressions in its class, equations
|
||||
involving a super-expression, and disequal expressions *)
|
||||
pnd: (Exp.t * Exp.t) list;
|
||||
(** pairs of expressions in carrier to be equated *)
|
||||
}
|
||||
(** See [invariant] below for additional representation properties. *)
|
||||
|
||||
|
||||
(* Formatting =============================================================== *)
|
||||
|
||||
let fmt ff {sat; rep; cls_use; pnd} =
|
||||
let fmt_assocl fmt_k fmt_v ff assocl =
|
||||
let fmt_assoc ff (k,v) =
|
||||
Format.fprintf ff "@[[%a => %a]@]" fmt_k k fmt_v v in
|
||||
Format.fprintf ff "@[<hv>%a@]" (List.fmt ";@ " fmt_assoc) assocl
|
||||
in
|
||||
let fmt_pnd ff pnd =
|
||||
let fmt_eq ff (e,f) = Format.fprintf ff "@[%a = %a@]" Exp.fmt e Exp.fmt f in
|
||||
if pnd <> [] then
|
||||
Format.fprintf ff "@ pnd= @[%a@];" (List.fmt ";@ " fmt_eq) pnd
|
||||
in
|
||||
let cls, use, dqs =
|
||||
ExpMap.fold (fun e (e_cls, e_use, e_dqs) (cls, use, dqs) ->
|
||||
let cls = (e, e_cls) :: cls in
|
||||
let use = if Use.is_empty e_use then use else (e, e_use) :: use in
|
||||
let dqs = if Dqs.is_empty e_dqs then dqs else (e, e_dqs) :: dqs in
|
||||
(cls, use, dqs)
|
||||
) cls_use ([],[],[])
|
||||
in
|
||||
Format.fprintf ff
|
||||
"@[{@[<hv>sat= %b;@ rep= %a;@ cls= %a;@ dqs= %a;@ use= %a;%a@]@;}@]"
|
||||
sat
|
||||
(fmt_assocl Exp.fmt Exp.fmt) (ExpMap.to_list rep)
|
||||
(fmt_assocl Exp.fmt Cls.fmt) cls
|
||||
(fmt_assocl Exp.fmt Dqs.fmt) dqs
|
||||
(fmt_assocl Exp.fmt Use.fmt) use
|
||||
fmt_pnd pnd
|
||||
|
||||
|
||||
(* Well-formedness ========================================================== *)
|
||||
|
||||
let is_rep e r =
|
||||
try ExpMap.find e r.rep == e
|
||||
with Not_found ->
|
||||
failwithf "%a should be a rep but is not in car of@ %a" Exp.fmt e fmt r
|
||||
|
||||
let in_car e r =
|
||||
ExpMap.mem e r.rep
|
||||
|
||||
let find_chk e m =
|
||||
try ExpMap.find e m with Not_found -> failwithf "%a not in car" Exp.fmt e
|
||||
|
||||
(* A property maintained by propagating individual equations. This is not
|
||||
strong enough to establish invariant below since it does not consider
|
||||
pending equations, which must be added and their consequences propagated
|
||||
before the relation is guaranteed to be closed. *)
|
||||
let pre_invariant r =
|
||||
not Config.check_cng || let()=()in
|
||||
ExpMap.iter (fun e e' ->
|
||||
(* carrier is closed under sub-expressions *)
|
||||
(match Exp.getApp e with None -> () | Some(f,a) ->
|
||||
assert( in_car f r );
|
||||
assert( in_car a r );
|
||||
);
|
||||
(* rep is idempotent, ie, every representative is its own representative *)
|
||||
assert( is_rep e' r
|
||||
|| failwithf "%a not rep in %a" Exp.fmt e' fmt r );
|
||||
(* every representative is in domain of cls_use *)
|
||||
assert( not (Exp.equal e e') || ExpMap.mem e' r.cls_use
|
||||
|| failwithf "%a not in cls_use %a" Exp.fmt e' fmt r );
|
||||
(* every expression is in class of its representative *)
|
||||
assert( Cls.mem e (fst3 (find_chk e' r.cls_use))
|
||||
|| failwithf "@[%a not in cls of %a in@ %a@]" Exp.fmt e Exp.fmt e' fmt r );
|
||||
(* use lists encode the super-expression relation for representatives, ie,
|
||||
for each application g(b)==e in the carrier *)
|
||||
if r.pnd = [] then
|
||||
(match Exp.getApp e with None -> () | Some(g,b) ->
|
||||
let aux g b =
|
||||
(* if an immediate sub-expression g is a representative *)
|
||||
try
|
||||
let _,use,_ = ExpMap.find g r.cls_use in
|
||||
let g' = g in
|
||||
let b' = find_chk b r.rep in
|
||||
(* then there is a corresponding equation f(a)==c in g's use list *)
|
||||
assert(
|
||||
Use.exists (fun (f,a,c) ->
|
||||
(* where equations correspond if they are equal under rep *)
|
||||
let f' = find_chk f r.rep in
|
||||
let a' = find_chk a r.rep in
|
||||
let c' = find_chk c r.rep in
|
||||
Exp.equal c' e'
|
||||
&& ( (Exp.equal f' g' && Exp.equal a' b')
|
||||
|| (Exp.equal f' b' && Exp.equal a' g') )
|
||||
) use
|
||||
|| failwithf "no use equation for %a(%a) = %a %a(%a) = %a"
|
||||
Exp.fmt b Exp.fmt g Exp.fmt e
|
||||
Exp.fmt b' Exp.fmt g' Exp.fmt e'
|
||||
)
|
||||
with Not_found -> ()
|
||||
in
|
||||
aux g b ;
|
||||
aux b g ;
|
||||
);
|
||||
(* relation is closed under a±F==b ==> a==b∓F *)
|
||||
if r.pnd = [] then
|
||||
(match Exp.getApp e with None -> () | Some(f,a) ->
|
||||
match Exp.invert f with None -> () | Some(inv_f) ->
|
||||
let a' = find_chk a r.rep in
|
||||
let e_inv_f' = find_chk (Exp.mkApp inv_f e') r.rep in
|
||||
assert( Exp.equal a' e_inv_f'
|
||||
|| failwithf "%a = %a but missing %a = %a (= %a(%a))"
|
||||
Exp.fmt e Exp.fmt e' Exp.fmt a' Exp.fmt e_inv_f' Exp.fmt inv_f Exp.fmt e' );
|
||||
);
|
||||
) r.rep
|
||||
;
|
||||
ExpMap.iter (fun e' (cls,use,dqs) ->
|
||||
(* every expression in domain of cls_use is a representative *)
|
||||
assert( is_rep e' r );
|
||||
(* rep maps every expression in class of e' to e' *)
|
||||
Cls.iter (fun e -> assert( find_chk e r.rep == e' ) ) cls ;
|
||||
(* every super-expression equation for e': *)
|
||||
Use.iter (fun (f,a,c) ->
|
||||
(* is between expressions in carrier *)
|
||||
let f' = find_chk f r.rep in
|
||||
let a' = find_chk a r.rep in
|
||||
let c' = find_chk c r.rep in
|
||||
(* involves an application super-expression of e' *)
|
||||
assert( Exp.equal f' e' || Exp.equal a' e' );
|
||||
(* is proved by the relation *)
|
||||
if r.pnd = [] then
|
||||
assert( Exp.equal (find_chk (Exp.mkApp f' a') r.rep) c'
|
||||
|| failwithf "%a(%a) = %a not proved" Exp.fmt f' Exp.fmt a' Exp.fmt c' );
|
||||
) use ;
|
||||
(* every expression in dqs is in carrier *)
|
||||
Dqs.iter (fun e ->
|
||||
assert( in_car e r )
|
||||
) dqs
|
||||
) r.cls_use
|
||||
;
|
||||
true
|
||||
|
||||
|
||||
(* A property maintained by exported operations. *)
|
||||
let invariant r =
|
||||
assert( r.pnd = [] );
|
||||
assert( pre_invariant r );
|
||||
true
|
||||
|
||||
|
||||
(* Helpers ================================================================== *)
|
||||
|
||||
let add_to_rep e e' rep =
|
||||
ExpMap.add e e' rep
|
||||
|
||||
let add_to_cls e' e cls_use =
|
||||
ExpMap.modify (fun (cls,use,dqs) -> (Cls.add e cls, use, dqs)) e' cls_use
|
||||
|
||||
let add_to_use e' fac cls_use =
|
||||
ExpMap.modify (fun (cls,use,dqs) -> (cls, Use.add fac use, dqs)) e' cls_use
|
||||
|
||||
let add_to_uses ((f',a',_) as fac) cls_use =
|
||||
add_to_use f' fac (add_to_use a' fac cls_use)
|
||||
|
||||
let add_to_dqs e' e r =
|
||||
{r with cls_use= ExpMap.modify (fun (cls,use,dqs) -> (cls, use, Dqs.add e dqs)) e' r.cls_use}
|
||||
|
||||
let union_to_dqs e' es r =
|
||||
{r with cls_use= ExpMap.modify (fun (cls,use,dqs) -> (cls, use, Dqs.union es dqs)) e' r.cls_use}
|
||||
|
||||
let add_to_pnd d e r =
|
||||
if Exp.equal d e then r else
|
||||
{r with pnd= (d, e) :: r.pnd}
|
||||
|
||||
let mem_dqs d' e' r =
|
||||
Dqs.mem e' (thd3 (ExpMap.find d' r.cls_use))
|
||||
|| Dqs.mem d' (thd3 (ExpMap.find e' r.cls_use))
|
||||
|
||||
|
||||
(* Extending the carrier ==================================================== *)
|
||||
|
||||
exception Found_extend
|
||||
exception Found_find_extend of Exp.t
|
||||
|
||||
let rec extend_ if_found r e =
|
||||
let rep = ExpMap.modify_add if_found e e r.rep in
|
||||
let cls_use = ExpMap.add e (Cls.singleton e, Use.empty, Dqs.empty) r.cls_use in
|
||||
let r = {r with rep; cls_use} in
|
||||
match Exp.getApp e with
|
||||
| Some(f,a) ->
|
||||
let f', r = find_extend f r in
|
||||
let a', r = find_extend a r in
|
||||
let f'_a', r = find_extend (Exp.mkApp f' a') r in
|
||||
let cls_use = add_to_uses (f',a',e) r.cls_use in
|
||||
let pnd = if Exp.equal f'_a' e then r.pnd else (f'_a', e) :: r.pnd in
|
||||
{r with cls_use; pnd}
|
||||
| None ->
|
||||
r
|
||||
|
||||
(** [find_extend e r] is [(e',r')] where [e] is in the carrier of [r'] and
|
||||
represented by [e']. [[r']] is the union of (e,e') and [[r]]. *)
|
||||
and find_extend e r =
|
||||
try
|
||||
(e, extend_ (fun e' -> raise (Found_find_extend e')) r e)
|
||||
with Found_find_extend e' ->
|
||||
(e', r)
|
||||
|
||||
let extend e r =
|
||||
try
|
||||
(fun r' -> assert(true$>
|
||||
L.printf 20 "extend: %a@,@[ %a@\n= %a@]" Exp.fmt e fmt r fmt r' ))
|
||||
<&
|
||||
extend_ (fun _ -> raise Found_extend) r e
|
||||
with Found_extend ->
|
||||
r
|
||||
|
||||
|
||||
(* Injectivity and Inverse axioms =========================================== *)
|
||||
|
||||
let apply_add_sub_axiom r f'_a' c' c'_cls =
|
||||
assert( Exp.sort_of f'_a' = Exp.sort_of c' );
|
||||
match Exp.getApp f'_a' with
|
||||
| None ->
|
||||
r
|
||||
| Some(f',a') ->
|
||||
assert(true$>
|
||||
L.incf 10 "( apply_add_sub_axiom: %a(%a) = %a@ %a@ %a"
|
||||
Exp.fmt f' Exp.fmt a' Exp.fmt c' Cls.fmt c'_cls fmt r );
|
||||
(fun r' -> assert(true$>
|
||||
L.decf 10 ") apply_add_sub_axiom:@ %a" fmt r' ))
|
||||
<&
|
||||
match Exp.invert f' with
|
||||
| None ->
|
||||
r
|
||||
| Some(inv_f) ->
|
||||
(* added a'±o==c', so add c∓o==a' for each c==c' *)
|
||||
Cls.fold (fun c r -> add_to_pnd (Exp.mkApp inv_f c) a' r) c'_cls r
|
||||
|
||||
|
||||
(* Propagating equalities =================================================== *)
|
||||
|
||||
(** [propagate1 e' e r] adds [e'==e] to [r] using [e'] as the representative. *)
|
||||
let propagate1 e' e r =
|
||||
assert(
|
||||
L.incf 10 "( propagate1:@ %a@ %a@ %a" Exp.fmt e' Exp.fmt e fmt r ;
|
||||
pre_invariant {r with pnd= (e',e) :: r.pnd} );
|
||||
(fun r' -> assert(
|
||||
L.decf 10 ") propagate1:@ %a" fmt r' ;
|
||||
pre_invariant r' ))
|
||||
<&
|
||||
(* remove class, superexp equations, and disequations of e, it is no longer a rep *)
|
||||
let (e_cls, e_use, e_dqs), cls_use = ExpMap.extract e r.cls_use in
|
||||
let r = {r with cls_use}
|
||||
in
|
||||
let r =
|
||||
Cls.fold (fun d r ->
|
||||
(* make e' the rep of every exp in class of e *)
|
||||
let r = {r with rep= ExpMap.add d e' r.rep} in
|
||||
(* and close under the axiom *)
|
||||
let e'_cls = if Exp.equal e' e then e_cls else fst3 (ExpMap.find e' r.cls_use) in
|
||||
apply_add_sub_axiom r d e' e'_cls
|
||||
) e_cls r
|
||||
in
|
||||
(* add disequalities of e to e' *)
|
||||
let r = union_to_dqs e' e_dqs r
|
||||
in
|
||||
(* closing under the axiom cannot promote e back to a rep *)
|
||||
assert( not (ExpMap.mem e r.cls_use) )
|
||||
;
|
||||
(* traverse up exp dag from e, whose rep changed, looking for new equations *)
|
||||
let r, e'_use_delta =
|
||||
Use.fold (fun (f,a,c) (r, e'_use_delta) ->
|
||||
let f' = ExpMap.find f r.rep in
|
||||
let a' = ExpMap.find a r.rep in
|
||||
let f'_a' = Exp.mkApp f' a' in
|
||||
try
|
||||
let b = ExpMap.find f'_a' r.rep in
|
||||
(* f'(a')==b already, so add b==c *)
|
||||
(add_to_pnd b c r, e'_use_delta)
|
||||
with Not_found ->
|
||||
(* f'(a') not in relation yet, so add f'(a')==c' *)
|
||||
let c' = ExpMap.find c r.rep in
|
||||
let rep = add_to_rep f'_a' c' r.rep in
|
||||
let cls_use = add_to_cls c' f'_a' r.cls_use in
|
||||
let r = {r with rep; cls_use} in
|
||||
let c'_cls,_,_ = ExpMap.find c' r.cls_use in
|
||||
let r = apply_add_sub_axiom r f'_a' c' c'_cls in
|
||||
(* Don't need to add (f',a',c') to use of f' or a' since e' is one of
|
||||
f' or a' and (f',a',c') will be added to use of e' below, and
|
||||
(f,a,c) will already be in use of the other. *)
|
||||
let e'_use_delta = Use.add (f',a',c') e'_use_delta in
|
||||
(r, e'_use_delta)
|
||||
) e_use (r, Use.empty)
|
||||
in
|
||||
(* add class and superexps of e to e' *)
|
||||
let cls_use =
|
||||
ExpMap.modify (fun (e'_cls, e'_use, e'_dqs) ->
|
||||
(Cls.union e_cls e'_cls, Use.union e'_use_delta e'_use, e'_dqs)
|
||||
) e' r.cls_use
|
||||
in
|
||||
{r with cls_use}
|
||||
|
||||
|
||||
module SortMMap =
|
||||
MultiMap.Make
|
||||
(struct type t = Var.sort let compare = Pervasives.compare let equal = Pervasives.( = ) end)
|
||||
(Exps)
|
||||
|
||||
|
||||
(** [propagate leq r] adds pending equations until closure reached. *)
|
||||
let rec propagate leq r =
|
||||
assert(
|
||||
L.incf 10 "( propagate:@ %a" fmt r ;
|
||||
pre_invariant r );
|
||||
(fun r' -> assert(
|
||||
L.decf 10 ") propagate:@ %a" fmt r' ;
|
||||
invariant r' ))
|
||||
<&
|
||||
match r.pnd with
|
||||
| [] ->
|
||||
r
|
||||
| (d,e) :: pnd ->
|
||||
let r = {r with pnd} in
|
||||
let d', r = find_extend d r in
|
||||
let e', r = find_extend e r in
|
||||
if Exp.equal d' e' then
|
||||
propagate leq r
|
||||
else if mem_dqs d' e' r then
|
||||
{r with sat= false; pnd= []}
|
||||
(* use e as the new rep if leq e d *)
|
||||
else if leq e' d' then
|
||||
propagate leq (propagate1 e' d' r)
|
||||
else
|
||||
propagate leq (propagate1 d' e' r)
|
||||
|
||||
|
||||
|
||||
|
||||
(* Exported operations ====================================================== *)
|
||||
|
||||
let normalize r e =
|
||||
try ExpMap.find e r.rep with Not_found -> e
|
||||
|
||||
|
||||
let mem r e f =
|
||||
Exp.equal (normalize r e) (normalize r f)
|
||||
|
||||
|
||||
let mem_dqs r e f =
|
||||
try mem_dqs (normalize r e) (normalize r f) r
|
||||
with Not_found -> false
|
||||
|
||||
|
||||
let inconsistent r =
|
||||
not r.sat
|
||||
|
||||
|
||||
let class_of r e =
|
||||
try Cls.to_set (fst3 (ExpMap.find (normalize r e) r.cls_use))
|
||||
with Not_found -> Exps.singleton e
|
||||
|
||||
|
||||
let mem_carrier e r =
|
||||
ExpMap.mem e r.rep
|
||||
|
||||
|
||||
let carrier r =
|
||||
ExpMap.fold (fun e _ car ->
|
||||
Exps.add e car
|
||||
) r.rep Exps.empty
|
||||
|
||||
|
||||
let representatives r =
|
||||
ExpMap.fold (fun e' _ reps ->
|
||||
Exps.add e' reps
|
||||
) r.cls_use Exps.empty
|
||||
|
||||
|
||||
let fold fn r z =
|
||||
ExpMap.fold (fun e' (cls,_,_) z ->
|
||||
Cls.fold (fun e z ->
|
||||
fn e' e z
|
||||
) (Cls.remove e' cls) z
|
||||
) r.cls_use z
|
||||
|
||||
|
||||
let foldn fn r z =
|
||||
ExpMap.fold (fun e' (_,_,dqs) z ->
|
||||
Dqs.fold (fun e z ->
|
||||
if Exp.compare e' e > 0 then z else
|
||||
fn e' e z
|
||||
) dqs z
|
||||
) r.cls_use z
|
||||
|
||||
|
||||
let fold_classes fn r z =
|
||||
ExpMap.fold (fun e' (cls,_,_) z ->
|
||||
fn e' (Cls.to_set cls) z
|
||||
) r.cls_use z
|
||||
|
||||
|
||||
let empty =
|
||||
(fun r -> assert( invariant r ))
|
||||
<&
|
||||
{ sat= true; rep= ExpMap.empty; cls_use= ExpMap.empty; pnd= []; }
|
||||
|
||||
|
||||
(** [merge leq r d e] adds an equation between expressions [d] and [e], and
|
||||
propagates consequences. Extends carrier as needed. *)
|
||||
let merge leq r d e =
|
||||
assert(true$>
|
||||
L.incf 10 "( merge: %a %s %a@ %a"
|
||||
Exp.fmt d (if leq e d then ">=" else "<") Exp.fmt e fmt r );
|
||||
(fun r' -> assert(
|
||||
L.decf 10 ") merge:@ %a" fmt r' ;
|
||||
invariant r'
|
||||
&&
|
||||
(not r'.sat
|
||||
||
|
||||
(normalize r' d == normalize r' e
|
||||
|| failwithf "%a = %a not in %a" Exp.fmt d Exp.fmt e fmt r' ) &&
|
||||
not (in_car d r && in_car e r)
|
||||
|| is_rep (normalize r' d) r ) ))
|
||||
(* Review: This assertion does not hold, check for reliance on it.
|
||||
|| let d0' = normalize r d and e0' = normalize r e
|
||||
and d' = normalize r' d and e' = normalize r' e in
|
||||
if leq e0' d0'
|
||||
then d' == e0' || failwithf "%a != %a" Exp.fmt d' Exp.fmt e0'
|
||||
else e' == d0' || failwithf "%a != %a" Exp.fmt e' Exp.fmt d0' ))
|
||||
*)
|
||||
<&
|
||||
if not r.sat then r else
|
||||
propagate leq (add_to_pnd d e (extend d (extend e r)))
|
||||
|
||||
|
||||
let split r d e =
|
||||
if not r.sat then r else
|
||||
let d', r = find_extend d r in
|
||||
let e', r = find_extend e r in
|
||||
if Exp.equal d' e' then
|
||||
{r with sat= false}
|
||||
else
|
||||
add_to_dqs d' e' (add_to_dqs e' d' r)
|
||||
|
||||
|
||||
let union leq p q =
|
||||
assert(true$>
|
||||
L.incf 10 "( union:@ @[<hv>%a@ %a@]" fmt p fmt q );
|
||||
(fun r -> assert(
|
||||
L.decf 10 ") union:@ %a" fmt r ;
|
||||
ExpMap.for_all (fun e f ->
|
||||
match leq e f, leq f e with
|
||||
| true, false ->
|
||||
Exp.equal (normalize r e) (normalize p f)
|
||||
|| failwithf "%a should have rep %a" Exp.fmt e Exp.fmt (normalize p f)
|
||||
| false, true ->
|
||||
Exp.equal (normalize r f) (normalize p e)
|
||||
|| failwithf "%a should have rep %a" Exp.fmt f Exp.fmt (normalize p e)
|
||||
| _ -> true
|
||||
) q.rep &&
|
||||
invariant r ))
|
||||
<&
|
||||
if not p.sat then p else if not q.sat then q else
|
||||
p |>
|
||||
ExpMap.fold (fun e e' r -> merge leq r e e') q.rep |>
|
||||
ExpMap.fold (fun e' (_,_,dqs) r -> Dqs.fold (fun e r -> split r e' e) dqs r) q.cls_use
|
||||
|
||||
|
||||
let inter leq p q =
|
||||
assert(true$>
|
||||
L.incf 10 "( inter:@ @[<hv>%a@ %a@]" fmt p fmt q );
|
||||
(fun r -> assert(
|
||||
L.decf 10 ") inter:@ %a" fmt r ;
|
||||
invariant r ))
|
||||
<&
|
||||
let merge_mem p q r =
|
||||
ExpMap.fold (fun e e' r ->
|
||||
if try Exp.equal (ExpMap.find e q.rep) (ExpMap.find e' q.rep) with Not_found -> false
|
||||
then merge leq r e e'
|
||||
else r
|
||||
) p.rep r
|
||||
in
|
||||
let split_dqs p q r =
|
||||
ExpMap.fold (fun e' (_,_,dqs) r ->
|
||||
Dqs.fold (fun e r ->
|
||||
if mem_dqs p e' e then
|
||||
split r e' e
|
||||
else
|
||||
r
|
||||
) dqs r
|
||||
) q.cls_use r
|
||||
in
|
||||
if not p.sat then q else if not q.sat then p else
|
||||
empty |>
|
||||
merge_mem q p |>
|
||||
merge_mem p q |>
|
||||
split_dqs q p |>
|
||||
split_dqs p q
|
||||
|
||||
|
||||
(* Notes *)
|
||||
(* - Is there a better implementation, that avoids enumerating the maps? *)
|
||||
(* - The carrier need not be preserved by subst since the carrier need not be
|
||||
closed under application of expressions in the carrier. Therefore a less
|
||||
naive implementation of updating the use lists is not obvious. *)
|
||||
(* - Specify more precisely. *)
|
||||
exception NewEquality of Exp.t * Exp.t
|
||||
let rec subst leq r kill_to_keep =
|
||||
assert(true$>
|
||||
L.incf 10 "( subst: %a@ %a" S.fmt kill_to_keep fmt r );
|
||||
(fun r' -> assert(
|
||||
L.decf 10 ") subst:@ %a" fmt r' ;
|
||||
(not (try invariant r with _ -> false)) || invariant r' ))
|
||||
<&
|
||||
if S.is_empty kill_to_keep then r
|
||||
else try
|
||||
let rep =
|
||||
ExpMap.fold (fun d d' rep ->
|
||||
let e = S.subst kill_to_keep d in
|
||||
let e' = S.subst kill_to_keep d' in
|
||||
try
|
||||
let f = ExpMap.find e r.rep in
|
||||
let f' = ExpMap.find e' r.rep in
|
||||
if not (Exp.equal f f') then
|
||||
(* Substituting revealed a new equality. This is possible since
|
||||
Substitution sees more internal structure of Expressions than
|
||||
CngRel does, for instance arithmetic expressions are treated as
|
||||
atoms in CngRel, but are substituted through. *)
|
||||
raise (NewEquality (f,f'))
|
||||
else
|
||||
raise Not_found
|
||||
with Not_found ->
|
||||
if Exp.equal e d then
|
||||
if Exp.equal e' d'
|
||||
then rep
|
||||
else ExpMap.add e e' rep
|
||||
else ExpMap.add e e' (ExpMap.remove d rep)
|
||||
) r.rep r.rep
|
||||
in
|
||||
let cls_use =
|
||||
ExpMap.fold (fun d' (cls,_,_) cls_use ->
|
||||
let e' = S.subst kill_to_keep d' in
|
||||
let cls =
|
||||
Cls.fold (fun e cls ->
|
||||
let e' = S.subst kill_to_keep e in
|
||||
if Exp.equal e e' then cls else Cls.add e' (Cls.remove e cls)
|
||||
) cls cls in
|
||||
let use = Use.empty in
|
||||
let dqs = Dqs.empty in
|
||||
if Exp.equal e' d'
|
||||
then ExpMap.add e' (cls,use,dqs) cls_use
|
||||
else ExpMap.add e' (cls,use,dqs) (ExpMap.remove d' cls_use)
|
||||
) r.cls_use r.cls_use
|
||||
in
|
||||
let r =
|
||||
ExpMap.fold (fun c _ r ->
|
||||
match Exp.getApp c with
|
||||
| None ->
|
||||
r
|
||||
| Some(f,a) ->
|
||||
let f', r = find_extend f r in
|
||||
let a', r = find_extend a r in
|
||||
{r with cls_use= add_to_uses (f',a',c) r.cls_use}
|
||||
) rep {r with rep; cls_use}
|
||||
in
|
||||
r
|
||||
with
|
||||
| NewEquality (f,f') ->
|
||||
(* add new equality and restart *)
|
||||
subst leq (merge leq r f f') kill_to_keep
|
||||
|
||||
|
||||
(* Notes *)
|
||||
(* - Is there a better implementation, that avoids enumerating the maps? *)
|
||||
(* - The result of restrict is not a well-formed relation. The carrier is
|
||||
not even closed under sub-expressions. Restrict should return a different
|
||||
type. *)
|
||||
let restrict r es =
|
||||
assert(
|
||||
L.incf 10 "( restrict: @[{%a}@]@ %a" Exps.fmt es fmt r;
|
||||
let reps = representatives r in
|
||||
Exps.subset reps es
|
||||
|| failwithf "reps not in es: {@[%a@]}" Exps.fmt (Exps.diff reps es) );
|
||||
(fun r -> assert(true$>
|
||||
L.decf 10 ") restrict:@ %a" fmt r ))
|
||||
<&
|
||||
(* restrict dom of rep to es *)
|
||||
let rep = ExpMap.filter (fun e _ -> Exps.mem e es) r.rep
|
||||
in
|
||||
let cls_use =
|
||||
ExpMap.fold (fun e' (cls,_,dqs) cls_use ->
|
||||
(* restrict dom of cls_use to es *)
|
||||
if not (Exps.mem e' es) then
|
||||
cls_use
|
||||
else
|
||||
(* restrict classes to es *)
|
||||
let cls = Cls.inter es cls in
|
||||
(* clear superexp equations *)
|
||||
let use = Use.empty in
|
||||
(* restrict disequalities to es *)
|
||||
let dqs = Dqs.inter es dqs in
|
||||
ExpMap.add e' (cls,use,dqs) cls_use
|
||||
) r.cls_use ExpMap.empty
|
||||
in
|
||||
{r with rep; cls_use}
|
||||
|
||||
|
||||
let remove_trivial r es =
|
||||
assert(true$>
|
||||
L.incf 10 "( remove_trivial: @[{%a}@]@ %a" Exps.fmt es fmt r );
|
||||
(fun r -> assert(true$>
|
||||
L.decf 10 ") remove_trivial:@ %a" fmt r ))
|
||||
<&
|
||||
Exps.fold (fun e r ->
|
||||
try
|
||||
let cls,_,_ = ExpMap.find e r.cls_use in
|
||||
if Cls.is_empty (Cls.remove e cls) then
|
||||
let rep = ExpMap.remove e r.rep in
|
||||
let cls_use = ExpMap.remove e r.cls_use in
|
||||
{r with rep; cls_use}
|
||||
else
|
||||
r
|
||||
with Not_found ->
|
||||
r
|
||||
) es r
|
||||
|
||||
|
||||
let implied_by leq init x assumptions carrier =
|
||||
let terms = Exps.to_array carrier in
|
||||
match Pure.get_implied_equalities x assumptions terms with
|
||||
| None ->
|
||||
empty
|
||||
| Some(ids) ->
|
||||
(* L.printf 0 "terms: @[%a@]" (Array.fmt "@ " Exp.fmt) terms ; *)
|
||||
(* L.printf 0 "ids: @[%a@]" (Array.fmt "@ " Format.pp_print_int) ids ; *)
|
||||
let n = Array.length terms in
|
||||
let id_to_rep = IntHMap.create n in
|
||||
snd (Array.fold_left (fun (i, cng) terms_i ->
|
||||
try
|
||||
let e' = IntHMap.find id_to_rep ids.(i) in
|
||||
(* L.printf 0 "merging %a and %a" Exp.fmt terms_i Exp.fmt e' ; *)
|
||||
(i+1, merge leq cng terms_i e')
|
||||
with Not_found ->
|
||||
(* L.printf 0 "choosing %a as rep for id %n" Exp.fmt terms_i ids.(i) ; *)
|
||||
IntHMap.add id_to_rep ids.(i) terms_i ;
|
||||
(i+1, merge leq cng terms_i terms_i)
|
||||
) (0, init) terms)
|
||||
|
||||
|
||||
let is_empty {rep; cls_use; pnd} =
|
||||
ExpMap.is_empty rep && ExpMap.is_empty cls_use && pnd = []
|
||||
|
||||
|
||||
(* Debug wrappers for entry points *)
|
||||
(* let merge = debug_wrap4 Config.vCng 10 merge *)
|
||||
(* let union = debug_wrap3 Config.vCng 10 union *)
|
||||
(* let inter = debug_wrap2 Config.vCng 10 inter *)
|
||||
(* let subst = debug_wrap2 Config.vCng 10 subst *)
|
||||
(* let restrict = debug_wrap2 Config.vCng 10 restrict *)
|
||||
(* let implied_by = debug_wrap5 Config.vCng 10 implied_by *)
|
||||
|
||||
|
||||
(* end *)
|
||||
(* include Make (Expression.Exp) (Expression.Exps) (Expression.ExpMap) *)
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Congruence-closed relations *)
|
||||
|
||||
open CONGRUENCE_RELATION
|
||||
open Expression
|
||||
|
||||
|
||||
include CONGRUENCE_RELATION with type exp := Exp.t and type exps := Exps.t
|
||||
|
|
@ -0,0 +1,541 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Configuration parameters *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
let next_lexicographic_permutation a =
|
||||
let rec loop1 k =
|
||||
if k <= 1 then raise Not_found
|
||||
else if a.(k-1) < a.(k) then k-1 else loop1 (k-1)
|
||||
in
|
||||
let rec loop2 k l =
|
||||
if a.(k) < a.(l) then l else loop2 k (l-1)
|
||||
in
|
||||
let n = Array.length a in
|
||||
try
|
||||
let k = loop1 (n-1) in
|
||||
let l = loop2 k (n-1) in
|
||||
Array.swap a k l ;
|
||||
Array.reverse a (k+1) n
|
||||
with Not_found ->
|
||||
()
|
||||
|
||||
let tag_perm = [|10;2;0;3;4;5;1;6;7;8;9|]
|
||||
|
||||
let rec set_perm i =
|
||||
if i > 0 then (
|
||||
next_lexicographic_permutation tag_perm ;
|
||||
set_perm (i-1)
|
||||
)
|
||||
|
||||
let _ = Random.self_init ()
|
||||
|
||||
let set_perm_randomly () =
|
||||
let rec factorial n = if n < 2 then 1 else n * factorial (n-1) in
|
||||
let i = Random.int (factorial (Array.length tag_perm)) in
|
||||
Printf.printf "using permutation %i" i ;
|
||||
set_perm i
|
||||
|
||||
|
||||
type precondition_order = Syntactic | Logical | WeakerSubheap
|
||||
|
||||
let precondition_order_of_string = function
|
||||
| "syntactic" -> Syntactic | "logical" -> Logical | "weaker-subheap" -> WeakerSubheap
|
||||
| _ -> raise (Arg.Bad "unrecognized precondition order")
|
||||
|
||||
let string_of_precondition_order = function
|
||||
| Syntactic -> "syntactic" | Logical -> "logical" | WeakerSubheap -> "weaker-subheap"
|
||||
|
||||
|
||||
let abs_query_to_gen = ref 0
|
||||
let c_syntax = ref false
|
||||
let check_abs = ref false
|
||||
let check_assumptions_time = ref infinity
|
||||
let check_cng = ref false
|
||||
let check_gie = ref false
|
||||
let check_gie_vs_cc = ref false
|
||||
let check_prv = ref false
|
||||
let check_sorts = ref true
|
||||
let check_scc = ref false
|
||||
let compile_only = ref false
|
||||
let continue = ref false
|
||||
let dcc_gie = ref true
|
||||
let distrib_pure = ref false
|
||||
let entails_time = ref infinity
|
||||
let exp_expand_ite = ref false
|
||||
let exp_hc_initial_size = ref 16381 (* Note: tune, taken from http://oeis.org/A014234/list *)
|
||||
let exp_simplify = ref true
|
||||
let filenames = ref []
|
||||
let font = ref (try Sys.getenv "SLAyer_FONT" with Not_found -> "")
|
||||
let frontend_args = ref []
|
||||
let full_results = ref false
|
||||
let generalize_call_retn = ref true
|
||||
let gie = ref 2
|
||||
let gie_incremental = ref true
|
||||
let gie_weak = ref false
|
||||
let instrument = ref false
|
||||
let join_powerset = ref true
|
||||
let join_reduce = ref 0
|
||||
let limit = ref 0
|
||||
let limit_ghosts = ref (-1)
|
||||
let margin = ref 176
|
||||
let margin_frac = ref 64.0
|
||||
let minor_heap_size = ref ((Gc.get()).Gc.minor_heap_size * Sys.word_size / (8*1024*1024))
|
||||
let no_builtins = ref false
|
||||
let norm_in_frontend = ref true
|
||||
let norm_query_to_gen = ref 0
|
||||
let optimize_frame = ref false
|
||||
let optimize_icall_targets = ref false
|
||||
let optimize_inline = ref 4
|
||||
let optimize_unused = ref true
|
||||
let optimize_liveness = ref true
|
||||
let optimize_boxing = ref true
|
||||
let precondition_order = ref WeakerSubheap
|
||||
let preserve_consts = ref true
|
||||
let propagate = ref false
|
||||
let prv_gen_test = ref 0
|
||||
let prv_simplify = ref true
|
||||
let prv_strong_valid_check = ref false
|
||||
let prv_valid_check = ref false
|
||||
let prv_wbn = ref true
|
||||
let ptr_size = ref 4
|
||||
let pur_eager_qe = ref true
|
||||
let quant_weight = ref 0
|
||||
let raise_exceptions = ref false
|
||||
let report_dead_code = ref false
|
||||
let reset_freq = ref 0
|
||||
let sh_simplify = ref true
|
||||
let sh_hoist_common_subformulas = ref true
|
||||
let show_unreachable = ref false
|
||||
let stats = ref false
|
||||
let subtract_time = ref infinity
|
||||
let trust_casts = ref false
|
||||
let tt_single_step = ref false
|
||||
let typ_hc_initial_size = ref 1021 (* Note: tune, taken from http://oeis.org/A014234/list *)
|
||||
let vATS = ref 0
|
||||
let vAbs = ref 0
|
||||
let vAbsH = ref 0
|
||||
let vCEx = ref 0
|
||||
let vCng = ref 0
|
||||
let vDCC = ref 0
|
||||
let vDiscovery = ref 0
|
||||
let vExp = ref 0
|
||||
let vFE = ref 0
|
||||
let vFrame = ref 0
|
||||
let vGraph = ref 0
|
||||
let vHG = ref 0
|
||||
let vInline = ref 0
|
||||
let vInstr = ref 0
|
||||
let vJoinPoint = ref 0
|
||||
let vLiveness = ref 0
|
||||
let vPrv = ref 0
|
||||
let vPure = ref 0
|
||||
let vRch = ref 0
|
||||
let vSE = ref 0
|
||||
let vSH = ref 0
|
||||
let vPgm = ref 0
|
||||
let vSubst = ref 0
|
||||
let vTr = ref 2
|
||||
let vTyp = ref 0
|
||||
let vVar = ref 2
|
||||
let vZ3 = ref 0
|
||||
let version_only = ref false
|
||||
let weak_pure_consequences = ref true
|
||||
let write_ats = ref false
|
||||
let write_cfg = ref false
|
||||
let write_cl_cfg = ref false
|
||||
let write_tt = ref false
|
||||
let z3_distinct = ref false
|
||||
let z3_ematching = ref true
|
||||
let z3_log = ref false
|
||||
let z3_memout = ref 0
|
||||
let z3_model = ref false
|
||||
let z3_print_mode = ref "full"
|
||||
let z3_relevancy = ref 0
|
||||
let z3_timeout = ref 0
|
||||
|
||||
|
||||
|
||||
let argspec = ref [
|
||||
(* options that select which results to compute *)
|
||||
("-version", Arg.Set version_only,
|
||||
" Report version and exit");
|
||||
("-c", Arg.Set compile_only,
|
||||
" Translate input to internal representation but do not analyze");
|
||||
("-cfg", Arg.Set write_cfg,
|
||||
" Write internal representation of program as a control-flow graph to .cfg.dot file");
|
||||
("-ats", Arg.Set write_ats,
|
||||
" Write abstract transition system to .ats.dot file");
|
||||
("-tt", Arg.Set write_tt,
|
||||
" Write counter-examples to defect.tt to view with sdvdefect");
|
||||
("-t2", Arg.Set instrument,
|
||||
" Generate instrumented arithmetic program for T2");
|
||||
|
||||
("-continue", Arg.Set continue,
|
||||
" Continue searching for errors after the first potential memory safety violation");
|
||||
("-propagate", Arg.Set propagate,
|
||||
" Propagate error conditions beyond potential memory safety violations");
|
||||
|
||||
(* options that affect external behavior *)
|
||||
("-frame", Arg.Bool (fun x -> optimize_frame := x),
|
||||
"<bool> Optimize: Frame \
|
||||
(default="^ (string_of_bool !optimize_frame) ^")");
|
||||
("-generalize-call-retn", Arg.Bool (fun x -> generalize_call_retn := x),
|
||||
"<bool> Generalize assertions at procedure call and return sites \
|
||||
(default="^ (string_of_bool !generalize_call_retn) ^")");
|
||||
("-join-powerset", Arg.Bool (fun x -> join_powerset := x),
|
||||
"<bool> Use powerset join instead of constructing disjunctive formulae \
|
||||
(default="^ (string_of_bool !join_powerset) ^")");
|
||||
("-limit", Arg.Set_int limit,
|
||||
"<int> Limit length of chains at a program point (0 for unlimited) \
|
||||
(default="^ (string_of_int !limit) ^")");
|
||||
("-limit-ghosts", Arg.Set_int limit_ghosts,
|
||||
" Limit on the number of stack frames worth of ghost variables kept \
|
||||
(default="^ (string_of_int !limit_ghosts) ^")");
|
||||
("-precondition-order", Arg.String (fun s -> precondition_order := precondition_order_of_string s),
|
||||
" The order relation to use for procedure preconditions, one of syntactic, logical, weaker-subheap \
|
||||
(default="^ (string_of_precondition_order !precondition_order) ^")");
|
||||
("-preserve-consts", Arg.Bool (fun x -> preserve_consts := x),
|
||||
"<bool> Preserve facts about program constants \
|
||||
(default="^ (string_of_bool !preserve_consts) ^")");
|
||||
("-trust-casts", Arg.Bool (fun x -> trust_casts := x),
|
||||
"<bool> Trust casts that increase object size \
|
||||
(default="^ (string_of_bool !trust_casts) ^")");
|
||||
|
||||
(* options that control progress reporting *)
|
||||
("-results", Arg.Set full_results,
|
||||
" Report full results");
|
||||
("-st", Arg.Set stats,
|
||||
" Report time and memory consumption statistics");
|
||||
("-dead", Arg.Set report_dead_code,
|
||||
" Report dead code");
|
||||
|
||||
("-ATS-show-unreachable", Arg.Bool (fun x -> show_unreachable := x),
|
||||
"<bool> Show unreachable states in the abstract transition system \
|
||||
(default="^(string_of_bool !show_unreachable)^")");
|
||||
("-ATS-reduce", Arg.Set_int join_reduce,
|
||||
"<int> Reduce the constructed abstract transition system by removing redundant vertices \
|
||||
(default="^ (string_of_int !join_reduce) ^")");
|
||||
("-tt-single-step", Arg.Set tt_single_step,
|
||||
" Expand counter-example traces in defect.tt to take a step for each internal instruction, \
|
||||
rather than the default one step per source line");
|
||||
|
||||
("-c-syntax", Arg.Set c_syntax,
|
||||
" Generate output in as close to C syntax as possible");
|
||||
("-margin", Arg.Set_int margin,
|
||||
"<int> The right margin used by the pretty printer \
|
||||
(default="^ (string_of_int !margin) ^")");
|
||||
("-margin-frac", Arg.Set_float margin_frac,
|
||||
"<float> The target columns/lines fraction of pretty printed graph vertices \
|
||||
(default="^ (string_of_float !margin_frac) ^")");
|
||||
("-font", Arg.Set_string font,
|
||||
"<string> The font used in dot graphs \
|
||||
(default="^ !font ^")");
|
||||
|
||||
("-vAbs", Arg.Set_int vAbs, "<int> Verbosity of Abstraction module");
|
||||
("-vAbsH", Arg.Set_int vAbsH, "<int> Verbosity of HeapAbstraction module");
|
||||
("-vATS", Arg.Set_int vATS, "<int> Verbosity of AbstractTransistionSystem module");
|
||||
("-vCEx", Arg.Set_int vCEx, "<int> Verbosity of CounterExample module");
|
||||
("-vCng", Arg.Set_int vCng, "<int> Verbosity of CngRel module");
|
||||
("-vDCC", Arg.Set_int vDCC, "<int> Verbosity of DisjCngClos module");
|
||||
("-vDiscovery", Arg.Set_int vDiscovery, "<int> Verbosity of Discovery module");
|
||||
("-vExp", Arg.Set_int vExp, "<int> Verbosity of Expression module");
|
||||
("-vFrame", Arg.Set_int vFrame, "<int> Verbosity of Frame module");
|
||||
("-vGraph", Arg.Set_int vGraph, "<int> Verbosity of Graph module");
|
||||
("-vHG", Arg.Set_int vHG, "<int> Verbosity of HeapGraph module");
|
||||
("-vInstr", Arg.Set_int vInstr, "<int> Verbosity of Instrumentation module");
|
||||
("-vPrv", Arg.Set_int vPrv, "<int> Verbosity of Prover module");
|
||||
("-vPure", Arg.Set_int vPure, "<int> Verbosity of Pure module") ;
|
||||
("-vRch", Arg.Set_int vRch, "<int> Verbosity of Reachability module");
|
||||
("-vSE", Arg.Set_int vSE, "<int> Verbosity of SymbolicExecution module");
|
||||
("-vSH", Arg.Set_int vSH, "<int> Verbosity of SymbolicHeap module");
|
||||
("-vPgm", Arg.Set_int vPgm, "<int> Verbosity of Program module");
|
||||
("-vSubst", Arg.Set_int vSubst, "<int> Verbosity of Substitution module");
|
||||
("-vTr", Arg.Set_int vTr, "<int> Verbosity of reporting ATS transitions (default="^ (string_of_int !vTr) ^")");
|
||||
("-vTyp", Arg.Set_int vTyp, "<int> Verbosity of Type module");
|
||||
("-vVar", Arg.Set_int vVar, "<int> Verbosity of Variable module");
|
||||
("-vZ3", Arg.Set_int vZ3, "<int> Verbosity of Z3 library") ;
|
||||
|
||||
(* options that control internal behavior but should not meaningfully affect results *)
|
||||
("-DCC-gie", Arg.Bool (fun x -> dcc_gie := x),
|
||||
"<bool> Call get_implied_equalities from DCC"
|
||||
^" (default="^(string_of_bool !dcc_gie)^")");
|
||||
|
||||
("-Exp-simplify", Arg.Bool (fun x -> exp_simplify := x),
|
||||
"<bool> Perform syntactic simplification of Expressions"
|
||||
^" (default="^(string_of_bool !exp_simplify)^")");
|
||||
("-Exp-expand-ite", Arg.Bool (fun x -> exp_expand_ite := x),
|
||||
"<bool> Expand if-then-else Expressions into disjunctions"
|
||||
^" (default="^(string_of_bool !exp_simplify)^")");
|
||||
("-Exp-hc-size", Arg.Set_int exp_hc_initial_size,
|
||||
"<int> Initial size of table for hash-consing Expressions"
|
||||
^" (default="^(string_of_int !exp_hc_initial_size)^")");
|
||||
("-Exp-compare", Arg.Int set_perm,
|
||||
"<int> Use the ith lexicographic permutation for comparing expressions");
|
||||
("-Exp-compare-random", Arg.Unit set_perm_randomly,
|
||||
" Use a random permutation for comparing expressions");
|
||||
|
||||
("-Pur-eager-qe", Arg.Bool (fun x -> pur_eager_qe := x),
|
||||
"<bool> Perform quantifier elimination when asserting formulas instead of when solving them \
|
||||
(default="^(string_of_bool !pur_eager_qe)^")");
|
||||
|
||||
("-Prv-simplify", Arg.Bool (fun x -> prv_simplify := x),
|
||||
"<bool> Simplify formulas during proof search \
|
||||
(default="^(string_of_bool !prv_simplify)^")");
|
||||
("-Prv-svc", Arg.Set prv_strong_valid_check,
|
||||
" Use a strong (and expensive) check to fail proof search early \
|
||||
(default="^(string_of_bool !prv_strong_valid_check)^")");
|
||||
("-Prv-vc", Arg.Set prv_valid_check,
|
||||
" Use a pure validity check to fail proof search early \
|
||||
(default="^(string_of_bool !prv_valid_check)^")");
|
||||
("-Prv-wbn", Arg.Bool (fun x -> prv_wbn := x),
|
||||
"<bool> Compute existential witnesses using normalization \
|
||||
(default="^(string_of_bool !prv_wbn)^")");
|
||||
|
||||
("-SH-distrib-pure", Arg.Bool (fun x -> distrib_pure := x),
|
||||
"<bool> Distribute pure conjunction under disjunction \
|
||||
(default="^(string_of_bool !distrib_pure)^")");
|
||||
("-SH-simplify", Arg.Bool (fun x -> sh_simplify := x),
|
||||
"<bool> Perform syntactic simplification of SymbolicHeaps"
|
||||
^" (default="^(string_of_bool !sh_simplify)^")");
|
||||
("-hcs", Arg.Unit (fun () -> sh_hoist_common_subformulas := not !sh_hoist_common_subformulas),
|
||||
" Hoist common subformulas out of disjunctions"
|
||||
^" (default="^(string_of_bool !sh_hoist_common_subformulas)^")");
|
||||
("-SH-weak-pure-consequences", Arg.Bool (fun x -> weak_pure_consequences := x),
|
||||
"<bool> Use a weak version of pure_consequences during normalization"
|
||||
^" (default="^(string_of_bool !weak_pure_consequences)^")");
|
||||
|
||||
("-Typ-hc-size", Arg.Set_int typ_hc_initial_size,
|
||||
"<int> Initial size of table for hash-consing Types"
|
||||
^" (default="^(string_of_int !typ_hc_initial_size)^")");
|
||||
|
||||
("-Z3-distinct", Arg.Bool (fun x -> z3_distinct := x),
|
||||
"<bool> Use 'distinct' formulas in Z3 encoding \
|
||||
(default="^ (string_of_bool !z3_distinct) ^")") ;
|
||||
("-Z3-quant-weight", Arg.Set_int quant_weight,
|
||||
"<int> Set the weight of quantifiers, used by Z3 \
|
||||
(default="^ (string_of_int !quant_weight) ^")") ;
|
||||
("-Z3-quant-inst", Arg.Bool (fun x -> z3_ematching := x),
|
||||
"<bool> Use heuristic quantifier instantiation \
|
||||
(default="^ (string_of_bool !z3_ematching) ^")") ;
|
||||
("-Z3-relevancy", Arg.Set_int z3_relevancy,
|
||||
"<int> relevancy propagation heuristic \
|
||||
(default="^ (string_of_int !z3_relevancy) ^")") ;
|
||||
("-Z3-timeout", Arg.Set_int z3_timeout,
|
||||
"<int> Set a time limit (in milliseconds) for calls to Z3") ;
|
||||
("-Z3-memout", Arg.Set_int z3_memout,
|
||||
"<int> Set a memory limit (in megabytes) for calls to Z3") ;
|
||||
("-Z3-rf", Arg.Set_int reset_freq,
|
||||
"<int> Z3 context reset frequency (0=never) \
|
||||
(default="^ (string_of_int !reset_freq) ^")") ;
|
||||
|
||||
("-gie", Arg.Set_int gie,
|
||||
"<int> Select 'get_implied_equalities' algorithm \
|
||||
(default="^ (string_of_int !gie) ^")") ;
|
||||
("-gie-incremental", Arg.Bool (fun x -> gie_incremental := x),
|
||||
"<bool> Manage assertions incrementally for 'get_implied_equalities' \
|
||||
(default="^ (string_of_bool !gie_incremental) ^")") ;
|
||||
("-gie-weak", Arg.Bool (fun x -> gie_weak := x),
|
||||
"<bool> Use weak encoding for 'get_implied_equalities' \
|
||||
(default="^ (string_of_bool !gie_weak) ^")") ;
|
||||
|
||||
("-minor-heap-size", Arg.Set_int minor_heap_size,
|
||||
"<int> Initial minor heap size in MB \
|
||||
(default="^ (string_of_int !minor_heap_size) ^")") ;
|
||||
|
||||
(* options for debugging *)
|
||||
("-checkCng", Arg.Bool (fun x -> check_cng := x),
|
||||
"<bool> Perform expensive checking of CngRel operations \
|
||||
(default="^ (string_of_bool !check_cng) ^")");
|
||||
("-checkGIE", Arg.Bool (fun x -> check_gie := x),
|
||||
"<bool> Check soundness and completeness of get_implied_equalities \
|
||||
(default="^ (string_of_bool !check_gie) ^")") ;
|
||||
("-checkGIEvsCC", Arg.Bool (fun x -> check_gie_vs_cc := x),
|
||||
"<bool> Check that get_implied_equalities and congruence closure have equal strength \
|
||||
(default="^ (string_of_bool !check_gie_vs_cc) ^")") ;
|
||||
("-checkAbs", Arg.Bool (fun x -> check_abs := x),
|
||||
"<bool> Use prover to check soundness of abstraction \
|
||||
(default="^ (string_of_bool !check_abs) ^")");
|
||||
("-checkPrv", Arg.Bool (fun x -> check_prv := x),
|
||||
"<bool> Use prover to check its own soundness \
|
||||
(default="^ (string_of_bool !check_prv) ^")");
|
||||
("-checkSorts", Arg.Bool (fun x -> check_sorts := x),
|
||||
"<bool> Check well-sortedness \
|
||||
(default="^ (string_of_bool !check_sorts) ^")") ;
|
||||
("-checkSCC", Arg.Bool (fun x -> check_scc := x),
|
||||
"<bool> Perform expensive checking of SCC operations \
|
||||
(default="^ (string_of_bool !check_scc) ^")");
|
||||
|
||||
("-exn", Arg.Set raise_exceptions,
|
||||
" Raise unhandled exceptions for internal errors");
|
||||
|
||||
("-gta", Arg.Set_int abs_query_to_gen,
|
||||
"<int> Generate standalone repro for Abstraction call number <int>");
|
||||
("-gtn", Arg.Set_int norm_query_to_gen,
|
||||
"<int> Generate repro for SymbolicHeap normalization");
|
||||
("-gtp", Arg.Set_int prv_gen_test,
|
||||
"<int> Generate standalone test for Prover query number <int>");
|
||||
|
||||
("-show-models", Arg.Set z3_model,
|
||||
" Display Z3 models") ;
|
||||
("-Z3-print-mode", Arg.Set_string z3_print_mode,
|
||||
"<string> Set Z3 printing mode: full, low, smt, smt2") ;
|
||||
|
||||
("-tca", Arg.Set_float check_assumptions_time,
|
||||
"<float> Report check_assumptions calls exceeding time. Negative for running max");
|
||||
("-te", Arg.Set_float entails_time,
|
||||
"<float> Report entails calls exceeding time. Negative for running max");
|
||||
("-ts", Arg.Set_float subtract_time,
|
||||
"<float> Report subtract calls exceeding time. Negative for running max");
|
||||
|
||||
("-Z3-log", Arg.Set z3_log,
|
||||
" Log Z3 interactions") ;
|
||||
|
||||
(* frontend args *)
|
||||
("--", Arg.Rest (fun rest -> frontend_args := List.append !frontend_args [rest]),
|
||||
" Pass remaining arguments to frontend");
|
||||
("-fe_norm", Arg.Bool (fun x -> norm_in_frontend := x),
|
||||
"<bool> Normalize internal representation of program before instead of after marshalling (default="^
|
||||
(string_of_bool !norm_in_frontend) ^")");
|
||||
("-fe_cfg", Arg.Set write_cl_cfg,
|
||||
" Write cl-dropped representation of program to .fe.cfg.dot file");
|
||||
("-no-builtins", Arg.Set no_builtins,
|
||||
" Do not include slayer.h when invoking C compiler");
|
||||
("-ptr-size", Arg.Set_int ptr_size,
|
||||
"<int> Size (in bytes) of pointers, e.g. 4 for 32-bit code or 8 for 64-bit code \
|
||||
(default="^ (string_of_int !ptr_size) ^")");
|
||||
("-Oicalls", Arg.Bool (fun x -> optimize_icall_targets := x),
|
||||
"<int> Optimize: Constrain static approximation of indirect call targets using types \
|
||||
(default="^ (string_of_bool !optimize_icall_targets) ^")");
|
||||
("-Oinline", Arg.Set_int optimize_inline,
|
||||
"<int> Optimize: Inline function calls (0=none, 1=loop- and call-free, 2=loop-free \
|
||||
non-recursive, 3=as 2 with single call site, 4=non-recursive) (default="^
|
||||
(string_of_int !optimize_inline) ^")");
|
||||
("-Oboxing", Arg.Bool (fun x -> optimize_boxing := x),
|
||||
"<int> Optimize: Only box address taken globals and global structs (default="^
|
||||
(string_of_bool !optimize_boxing) ^")");
|
||||
("-Oliveness", Arg.Bool (fun x -> optimize_liveness := x),
|
||||
"<bool> Optimize: Apply liveness transformations \
|
||||
(default="^ (string_of_bool !optimize_liveness) ^")");
|
||||
("-Ounused", Arg.Bool (fun x -> optimize_unused := x),
|
||||
"<bool> Optimize: Remove unused globals variables \
|
||||
(default="^ (string_of_bool !optimize_unused) ^")");
|
||||
("-vFE", Arg.Set_int vFE,
|
||||
"<int> Verbosity of Frontend module");
|
||||
("-vInline", Arg.Set_int vInline,
|
||||
"<int> Verbosity of Inline module");
|
||||
("-vJoinPoint", Arg.Set_int vJoinPoint,
|
||||
"<int> Verbosity of JoinPoint module");
|
||||
("-vLiveness", Arg.Set_int vLiveness,
|
||||
"<int> Verbosity of Liveness module");
|
||||
]
|
||||
|
||||
|
||||
let _ =
|
||||
let argspec = Arg.align !argspec
|
||||
and anon_arg_func fname = filenames := fname :: !filenames
|
||||
and usage = "Usage: "^Sys.argv.(0)^" <options> {-version | <file>.{c | sil}}"
|
||||
in
|
||||
Arg.parse argspec anon_arg_func usage
|
||||
;
|
||||
Format.pp_set_margin Format.str_formatter !margin
|
||||
;
|
||||
let good_usage =
|
||||
!version_only ||
|
||||
(match !filenames with
|
||||
| [] -> false
|
||||
| [fname] -> Filename.check_suffix fname ".c" || Filename.check_suffix fname ".sil"
|
||||
| fnames -> List.for_all (fun fname -> Filename.check_suffix fname ".c") fnames
|
||||
)
|
||||
in
|
||||
if not good_usage then (
|
||||
Arg.usage argspec usage ;
|
||||
exit 1
|
||||
)
|
||||
|
||||
|
||||
let abs_query_to_gen = !abs_query_to_gen
|
||||
let check_abs = !check_abs
|
||||
let check_assumptions_time = !check_assumptions_time
|
||||
let check_cng = !check_cng
|
||||
let check_gie = !check_gie
|
||||
let check_gie_vs_cc = !check_gie_vs_cc
|
||||
let check_prv = !check_prv
|
||||
let check_sorts = !check_sorts
|
||||
let check_scc = !check_scc
|
||||
let compile_only = !compile_only
|
||||
let continue = !continue
|
||||
let dcc_gie = !dcc_gie
|
||||
let distrib_pure = !distrib_pure
|
||||
let entails_time = !entails_time
|
||||
let exp_expand_ite = !exp_expand_ite
|
||||
let exp_hc_initial_size = !exp_hc_initial_size
|
||||
let exp_simplify = !exp_simplify
|
||||
let filenames = List.rev !filenames
|
||||
let font = !font
|
||||
let frontend_args = !frontend_args
|
||||
let full_results = !full_results
|
||||
let generalize_call_retn = !generalize_call_retn
|
||||
let gie = !gie
|
||||
let gie_incremental = !gie_incremental
|
||||
let gie_weak = !gie_weak
|
||||
let instrument = !instrument
|
||||
let join_powerset = !join_powerset
|
||||
let join_reduce = !join_reduce
|
||||
let limit = !limit
|
||||
let limit_ghosts = !limit_ghosts
|
||||
let margin = !margin
|
||||
let margin_frac = !margin_frac
|
||||
let minor_heap_size = !minor_heap_size
|
||||
let no_builtins = !no_builtins
|
||||
let norm_in_frontend = !norm_in_frontend
|
||||
let norm_query_to_gen = !norm_query_to_gen
|
||||
let optimize_frame = !optimize_frame
|
||||
let optimize_icall_targets = !optimize_icall_targets
|
||||
let optimize_inline = !optimize_inline
|
||||
let optimize_liveness = !optimize_liveness
|
||||
let optimize_unused = !optimize_unused
|
||||
let optimize_boxing = !optimize_boxing
|
||||
let precondition_order = !precondition_order
|
||||
let preserve_consts = !preserve_consts
|
||||
let propagate = !propagate
|
||||
let prv_gen_test = !prv_gen_test
|
||||
let prv_simplify = !prv_simplify
|
||||
let prv_strong_valid_check = !prv_strong_valid_check
|
||||
let prv_valid_check = !prv_valid_check
|
||||
let prv_wbn = !prv_wbn
|
||||
let ptr_size = !ptr_size
|
||||
let pur_eager_qe = !pur_eager_qe
|
||||
let quant_weight = !quant_weight
|
||||
let raise_exceptions = !raise_exceptions
|
||||
let report_dead_code = !report_dead_code
|
||||
let reset_freq = !reset_freq
|
||||
let sh_simplify = !sh_simplify
|
||||
let sh_hoist_common_subformulas = !sh_hoist_common_subformulas
|
||||
let show_unreachable = !show_unreachable
|
||||
let stats = !stats
|
||||
let subtract_time = !subtract_time
|
||||
let trust_casts = !trust_casts
|
||||
let tt_single_step = !tt_single_step
|
||||
let typ_hc_initial_size = !typ_hc_initial_size
|
||||
let version_only = !version_only
|
||||
let weak_pure_consequences = !weak_pure_consequences
|
||||
let write_ats = !write_ats
|
||||
let write_cfg = !write_cfg
|
||||
let write_cl_cfg = !write_cl_cfg
|
||||
let write_tt = !write_tt
|
||||
let z3_distinct = !z3_distinct
|
||||
let z3_ematching = !z3_ematching
|
||||
let z3_log = !z3_log
|
||||
let z3_memout = !z3_memout
|
||||
let z3_model = !z3_model
|
||||
let z3_print_mode = !z3_print_mode
|
||||
let z3_relevancy = !z3_relevancy
|
||||
let z3_timeout = !z3_timeout
|
||||
|
||||
let testname =
|
||||
match filenames with
|
||||
| [fname] -> Filename.chop_extension fname
|
||||
| _ -> Filename.basename (Sys.getcwd ())
|
||||
|
|
@ -0,0 +1,354 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Generation of counter-example trace for sdvdefect viewer *)
|
||||
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
open Program
|
||||
module I = Inst
|
||||
module C = Cmnd
|
||||
module K = ControlPoint
|
||||
module SHD = Analysis.SymbolicHeapsDomain
|
||||
module ID = Analysis.InterprocDomain
|
||||
module ATS = ID.ATS
|
||||
module Tr = ID.Tr
|
||||
|
||||
module L = (val Log.std Config.vCEx : Log.LOG)
|
||||
|
||||
|
||||
exception Unsupported
|
||||
|
||||
|
||||
(*================================================================================================================
|
||||
Abstract Counter-Example Traces
|
||||
================================================================================================================*)
|
||||
|
||||
let path_between shortest ats start error =
|
||||
let cmp0 x y =
|
||||
if shortest then x <= y else x >= y
|
||||
in
|
||||
let dist =
|
||||
let vtx_to_idx,_, dist,_ = ATS.fw ats in
|
||||
let to_idx vtx = ATS.VertexIMap.tryfind vtx_to_idx vtx |> Option.get in
|
||||
let error_idx = to_idx error in
|
||||
fun vtx ->
|
||||
dist.(to_idx vtx).(error_idx)
|
||||
in
|
||||
let rec walk cmp m vtx =
|
||||
if ATS.Vertex.equal error vtx then
|
||||
[]
|
||||
else match
|
||||
ATS.fold_succs (fun succ edge dist_edge_succ ->
|
||||
let succ_dist = dist succ in
|
||||
match dist_edge_succ with
|
||||
| Some(dist,_,_) when cmp dist succ_dist ->
|
||||
dist_edge_succ
|
||||
| _ ->
|
||||
Some(succ_dist, edge, succ)
|
||||
) vtx None
|
||||
with
|
||||
| Some(_, edge, succ) ->
|
||||
if ATS.VertexSet.mem succ m then
|
||||
(vtx, edge) :: walk ( <= ) m succ
|
||||
else
|
||||
(vtx, edge) :: walk cmp0 (ATS.VertexSet.add succ m) succ
|
||||
| None ->
|
||||
[]
|
||||
in
|
||||
walk cmp0 (ATS.VertexSet.singleton start) start
|
||||
|
||||
|
||||
let fmt_path ff (path, error) =
|
||||
Format.fprintf ff "%a@\n%a"
|
||||
(List.fmt "@\n" (fun ff (v,e) -> Format.fprintf ff "@[<v 4>%a@\n%a@\n@]" ATS.Vertex.fmt v Tr.fmt e)) path
|
||||
ATS.Vertex.fmt error
|
||||
|
||||
|
||||
(*================================================================================================================
|
||||
Generation of Counter-Example Traces for sdvdefect
|
||||
================================================================================================================*)
|
||||
|
||||
module SdvDefect = struct
|
||||
|
||||
(* Some characters are interpreted specially by statestr2state in TraceTreeParser.cs:
|
||||
'^' is translated to '\n' and '_' is translated to ' '. *)
|
||||
let refmt fmt x =
|
||||
let src_buf = Buffer.create 1024 in
|
||||
let ff = Format.formatter_of_buffer src_buf in
|
||||
Format.pp_set_margin ff Config.margin ;
|
||||
fmt ff x ;
|
||||
Format.pp_print_flush ff () ;
|
||||
let dst_buf = Buffer.create 1024 in
|
||||
for i = 0 to Buffer.length src_buf - 1 do
|
||||
match Buffer.nth src_buf i with
|
||||
(* apply inverse of sdvdefect's translation when generating defect.tt files *)
|
||||
| '\n' -> Buffer.add_string dst_buf "^"
|
||||
| ' ' -> Buffer.add_string dst_buf "_"
|
||||
(* translate specially interpreted characters to avoid sdvdefect's translation *)
|
||||
| '^' -> Buffer.add_string dst_buf "/\\"
|
||||
| '_' -> Buffer.add_string dst_buf "."
|
||||
| char -> Buffer.add_char dst_buf char
|
||||
done ;
|
||||
Buffer.contents dst_buf
|
||||
|
||||
|
||||
(* sdvdefect generally does not accept empty/whitespace strings *)
|
||||
let fmt_str ff x =
|
||||
Format.pp_print_string ff (if x = "" then "?" else x)
|
||||
|
||||
|
||||
(* Regular expressions below are those from TraceTreeParser.cs used to parse defect.tt "InstructionType"s. *)
|
||||
|
||||
(* "^(?<step>[0-9]+)[ \\t\"]+(?<file>[^\"]+)[ \\t\"]+(?<line>[0-9]+)[ \\t]+(?<isslice>[^ ]+)[ \\t]+(?<state>[^ ]+)[ \\t]+Call[ \t]+\"(?<caller>[^\"]+)\"+[ \\t]+\"(?<callee>[^\"]+)\"[ \\t]*" *)
|
||||
let write_call fmt_state ff (step, file, line, isslice, state, caller, callee) =
|
||||
Format.fprintf ff "%d %a %d %a %a Call \"%a\" \"%a\"@\n"
|
||||
step fmt_str file line fmt_str isslice fmt_str (refmt fmt_state state) fmt_str caller fmt_str callee
|
||||
|
||||
(* "^(?<step>[0-9]+)[ \\t\"]+(?<file>[^\"]+)[ \\t\"]+(?<line>[0-9]+)[ \\t]+(?<isslice>[^ ]+)[ \\t]+(?<state>[^ ]+)[ \\t]+Return[ \\t]*" *)
|
||||
let write_return fmt_state ff (step, file, line, isslice, state) =
|
||||
Format.fprintf ff "%d %a %d %a %a Return@\n"
|
||||
step fmt_str file line fmt_str isslice fmt_str (refmt fmt_state state)
|
||||
|
||||
(* "^(?<step>[0-9]+)[ \\t\"]+(?<file>[^\"]+)[ \\t\"]+(?<line>[0-9]+)[ \\t]+(?<isslice>[^ ]+)[ \\t]+(?<state>[^ ]+)[ \\t]+Atomic[ \\t]+(?<desc>[^ ]+)[ \\t]*" *)
|
||||
let write_atomic fmt_state ff (step, file, line, isslice, state, desc) =
|
||||
Format.fprintf ff "%d %a %d %a %a Atomic %a@\n"
|
||||
step fmt_str file line fmt_str isslice fmt_str (refmt fmt_state state) fmt_str desc
|
||||
|
||||
(* "^Driver([ \\t\"]+)(?<driver>[^\"]+)[ \\t\"]*" *)
|
||||
let write_driver ff driver =
|
||||
Format.fprintf ff "Driver %a@\n"
|
||||
fmt_str driver
|
||||
|
||||
(* "^Rule[ \\t]+(?<rule>[^ ]+)[ \\t]*" *)
|
||||
let write_rule ff rule =
|
||||
Format.fprintf ff "Rule %a@\n"
|
||||
fmt_str rule
|
||||
|
||||
(* "^Error[ \\t]+(?<error>.* )" *)
|
||||
(* sdvdefect complains if there is more than one Error per defect file *)
|
||||
let _write_pattern ff error =
|
||||
Format.fprintf ff "Error %a@\n"
|
||||
fmt_str error
|
||||
|
||||
end
|
||||
|
||||
|
||||
let write_defect_tt_path fmt ff path =
|
||||
let step =
|
||||
let step = ref 0 in
|
||||
fun () ->
|
||||
incr step ;
|
||||
!step
|
||||
in
|
||||
let write_blk vtx blk =
|
||||
let {I.pos= {Position.dir; file; line}} = List.hd blk in
|
||||
let fmt_blk ff blk = Format.fprintf ff "@[<hv>%a;@]" (List.fmt ";@ " I.fmt) blk in
|
||||
let fmt_state ff (vtx, blk) = Format.fprintf ff "@\n%a@\n@\n%a" fmt vtx fmt_blk blk in
|
||||
SdvDefect.write_atomic fmt_state ff (step(), dir^"\\"^file, line, "false", (vtx, blk), "")
|
||||
in
|
||||
let write_call vtx ({Call.proc= {Proc.id}} as call) =
|
||||
let _,k = ID.I_D_cp.project vtx in
|
||||
let {Position.dir; file; line} = K.pos k in
|
||||
let fmt_call ff call = Call.fmt (fun ff {Proc.id} -> Proc.Id.fmt ff id) ff call in
|
||||
let fmt_state ff (vtx, call) = Format.fprintf ff "@\n%a@\n%a" (Option.fmt "" fmt) vtx fmt_call call in
|
||||
let caller = Proc.Id.name (K.proc k) in
|
||||
let callee = Proc.Id.name id in
|
||||
SdvDefect.write_call fmt_state ff (step(), dir^"\\"^file, line, "false", (Some vtx, call), caller, callee)
|
||||
in
|
||||
let write_retn vtx =
|
||||
let _,k = ID.I_D_cp.project vtx in
|
||||
let {Position.dir; file; line} = K.pos k in
|
||||
let fmt_state ff vtx = Format.fprintf ff "@\n%a@\nreturn" (Option.fmt "" fmt) vtx in
|
||||
SdvDefect.write_return fmt_state ff (step(), dir^"\\"^file, line, "false", Some vtx)
|
||||
in
|
||||
let rec write_path = function
|
||||
| (vtx, edg) :: path ->
|
||||
(match edg with
|
||||
| Tr.Intra(_, [], _,_) -> ()
|
||||
| Tr.Intra(_, blk, _,_) -> write_blk vtx blk
|
||||
| Tr.Call(call) -> write_call vtx call
|
||||
| Tr.Return -> write_retn vtx
|
||||
| Tr.Summary -> ()
|
||||
);
|
||||
write_path path
|
||||
| [] ->
|
||||
()
|
||||
in
|
||||
write_path path
|
||||
|
||||
|
||||
let write_defect_tt paths buf =
|
||||
let c_syntax = !Config.c_syntax in
|
||||
Config.c_syntax := not c_syntax ;
|
||||
let ff = Format.formatter_of_buffer buf in
|
||||
SdvDefect.write_driver ff Config.testname ;
|
||||
SdvDefect.write_rule ff "Memory Safety" ;
|
||||
(* To include multiple traces in one file,
|
||||
add a bogus toplevel Call/Return and a bogus Call/Return around each trace. *)
|
||||
SdvDefect.write_call (fun _ () -> ()) ff (0, "", 0, "true", (), "", "Counter-examples") ;
|
||||
List.iter (fun (name, path, fmt) ->
|
||||
SdvDefect.write_call (fun _ () -> ()) ff (0, "", 0, "true", (), "", name) ;
|
||||
write_defect_tt_path fmt ff path ;
|
||||
SdvDefect.write_return (fun _ () -> ()) ff (0, "", 0, "true", ())
|
||||
) paths ;
|
||||
SdvDefect.write_return (fun _ () -> ()) ff (0, "", 0, "true", ()) ;
|
||||
Config.c_syntax := c_syntax
|
||||
|
||||
|
||||
(*================================================================================================================
|
||||
Abstract Counter-Example Transition Systems
|
||||
================================================================================================================*)
|
||||
|
||||
let error_slice ats start_vtx error_vtx =
|
||||
let ats_to_slice, error_slice = ATS.slice start_vtx error_vtx ats in
|
||||
let start_vtx = Option.get (ATS.VertexMap.tryfind start_vtx ats_to_slice) in
|
||||
let error_vtx = Option.get (ATS.VertexMap.tryfind error_vtx ats_to_slice) in
|
||||
(error_slice, start_vtx, error_vtx)
|
||||
|
||||
|
||||
let add_intermediate_states {Prog.globals; procs} ats start_vtx =
|
||||
let proc = Proc.IdHMap.tryfind procs (K.proc (snd (ID.I_D_cp.project start_vtx))) |> Option.get in
|
||||
let {Proc.id; formals; freturn; locals} = proc in
|
||||
let cfg = CFG.create () in
|
||||
let cxt = Vars.union globals (Vars.adds formals (Option.fold Vars.add freturn locals)) in
|
||||
ATS.iter_edges (fun _ -> ()) (fun (u,tr,w) ->
|
||||
match tr with
|
||||
| Tr.Intra(_, (_::_::_ as c), _, leak) ->
|
||||
let blks = List.divide (fun i j -> (not Config.tt_single_step) && I.(Position.equal i.pos j.pos)) c in
|
||||
let rec loop u p blks =
|
||||
match blks with
|
||||
| [] ->
|
||||
()
|
||||
| [blk] ->
|
||||
let tr = Tr.Intra(ATS.index_of u, blk, ATS.index_of w, leak) in
|
||||
ATS.add_edge ats u tr w
|
||||
| blk :: blks ->
|
||||
let h = ATS.index_of u in
|
||||
let {I.pos} = List.hd blk in
|
||||
let k = CFG.add_vertex cfg (K.mk_label pos id) in
|
||||
let tr = Tr.Intra(h, blk, k, false) in
|
||||
let q = List.fold_left (fun q i -> ID.RD.exec_inst cxt i q) p blk in
|
||||
let v = ATS.add_vertex ats (k, q) in
|
||||
ATS.add_edge ats u tr v ;
|
||||
loop v q blks
|
||||
in
|
||||
ATS.remove_edge ats u tr w ;
|
||||
let p,_ = ID.I_D_cp.project u in
|
||||
loop u p blks
|
||||
| _ ->
|
||||
()
|
||||
) ats (ATS.index_of start_vtx)
|
||||
|
||||
|
||||
let add_error_loops program ats start_vtx error_vtx =
|
||||
L.incf 10 "( add_error_loops" ; (fun _ -> L.decf 10 ") add_error_loops") <&
|
||||
let {Prog.procs} = program in
|
||||
let vtx_map, ats = ATS.copy ats start_vtx in
|
||||
let start_vtx = Option.get (ATS.VertexMap.tryfind start_vtx vtx_map) in
|
||||
let error_vtx = Option.get (ATS.VertexMap.tryfind error_vtx vtx_map) in
|
||||
ATS.iter_preds (fun pred_vtx _ ->
|
||||
L.printf 10 "error predecessor: %a" ATS.Vertex.fmt pred_vtx ;
|
||||
let pred_k = ATS.index_of pred_vtx in
|
||||
let pred_kid = K.id pred_k in
|
||||
let proc = K.proc pred_k in
|
||||
let {Proc.cfg} = Option.get (Proc.IdHMap.tryfind procs proc) in
|
||||
let cfg_scc_of = CFG.scc cfg in
|
||||
let pred_cfg_vtx = List.hd (CFG.vertices_for cfg pred_kid) in
|
||||
let pred_cfg_scc = CFG.VertexSet.of_list (Option.get (CFG.VertexMap.tryfind pred_k cfg_scc_of)) in
|
||||
let pred_cfg_scc_wo_pred = CFG.VertexSet.remove pred_cfg_vtx pred_cfg_scc in
|
||||
let cfg_to_ats = CFG.VertexMap.singleton pred_cfg_vtx pred_vtx in
|
||||
CFG.fold_edges
|
||||
(fun cfg_vtx cfg_to_ats ->
|
||||
if not (CFG.VertexSet.mem cfg_vtx pred_cfg_scc_wo_pred) then cfg_to_ats else
|
||||
let ats_vtx = ATS.add_vertex ats (cfg_vtx, ID.RD.inject SHD.tt) in
|
||||
CFG.VertexMap.add cfg_vtx ats_vtx cfg_to_ats
|
||||
)
|
||||
(fun (u,c,v) cfg_to_ats ->
|
||||
match CFG.VertexMap.tryfind u cfg_to_ats, c, CFG.VertexMap.tryfind v cfg_to_ats with
|
||||
| Some(u'), C.Inst(i), Some(v') ->
|
||||
let c' = Tr.Intra(u, [i], v, false) in
|
||||
ATS.add_edge ats u' c' v' ;
|
||||
cfg_to_ats
|
||||
| Some _, c, Some _ ->
|
||||
L.printf 1 "CounterExample: unexpected command: %a" C.fmt c ;
|
||||
raise Unsupported
|
||||
| _ ->
|
||||
cfg_to_ats
|
||||
) cfg pred_kid cfg_to_ats
|
||||
|> ignore
|
||||
) error_vtx ;
|
||||
ATS.concat_blocks ats start_vtx ;
|
||||
(ats, start_vtx, error_vtx)
|
||||
|
||||
|
||||
(*================================================================================================================
|
||||
Counter-Example Generation Driver
|
||||
================================================================================================================*)
|
||||
|
||||
let fmt_ats_state ff v =
|
||||
ID.RD.fmt ff (fst (ID.I_D_cp.project v))
|
||||
|
||||
|
||||
let disprove results =
|
||||
L.incf 10 "( disprove" ; (fun _ -> L.decf 10 ") disprove") <&
|
||||
try
|
||||
let {Analysis.program; invariants} = results in
|
||||
let ats = ID.ats invariants in
|
||||
let start_vtx = List.hd (ATS.roots ats) in
|
||||
let traces =
|
||||
[]
|
||||
|>
|
||||
List.fold_right (fun error_vtx traces ->
|
||||
L.incf 10 "( error: %a" ATS.Vertex.fmt error_vtx ; (fun _ -> L.decf 10 ")") <&
|
||||
let error_id = string_of_int (ATS.VertexIMap.find (ATS.identify_vertices ats) error_vtx) in
|
||||
|
||||
let error_slice, slice_start_vtx, slice_error_vtx = error_slice ats start_vtx error_vtx in
|
||||
if Config.write_ats then
|
||||
ID.write_ats (Config.testname^".o.err"^error_id) program error_slice (ATS.index_of slice_start_vtx) ;
|
||||
|
||||
add_intermediate_states program error_slice slice_start_vtx ;
|
||||
if Config.write_ats then
|
||||
ID.write_ats (Config.testname^".d.err"^error_id) program error_slice (ATS.index_of slice_start_vtx) ;
|
||||
|
||||
let error_loops, loops_start_vtx, _ = add_error_loops program ats start_vtx error_vtx in
|
||||
if Config.write_ats then
|
||||
ID.write_ats (Config.testname^".l.err"^error_id) program error_loops (ATS.index_of loops_start_vtx) ;
|
||||
|
||||
let shortest_path = path_between true error_slice slice_start_vtx slice_error_vtx in
|
||||
L.printf 1 "@\nshortest error path:@\n%a" fmt_path (shortest_path, error_vtx) ;
|
||||
let longest_path = path_between false error_slice slice_start_vtx slice_error_vtx in
|
||||
L.printf 1 "@\nlongest error path:@\n%a" fmt_path (longest_path, error_vtx) ;
|
||||
|
||||
("Shortest abstract path to Access Violation "^error_id, shortest_path, fmt_ats_state) ::
|
||||
("Longest abstract path to Access Violation "^error_id, longest_path, fmt_ats_state) ::
|
||||
traces
|
||||
) (Analysis.errors results)
|
||||
|>
|
||||
List.fold_right (fun leak_vtx traces ->
|
||||
L.incf 10 "( leak: %a" ATS.Vertex.fmt leak_vtx ; (fun _ -> L.decf 10 ")") <&
|
||||
let leak_id = string_of_int (ATS.VertexIMap.find (ATS.identify_vertices ats) leak_vtx) in
|
||||
|
||||
let leak_slice, slice_start_vtx, slice_leak_vtx = error_slice ats start_vtx leak_vtx in
|
||||
if Config.write_ats then
|
||||
ID.write_ats (Config.testname^".o.leak"^leak_id) program leak_slice (ATS.index_of slice_start_vtx) ;
|
||||
|
||||
add_intermediate_states program leak_slice slice_start_vtx ;
|
||||
if Config.write_ats then
|
||||
ID.write_ats (Config.testname^".d.leak"^leak_id) program leak_slice (ATS.index_of slice_start_vtx) ;
|
||||
|
||||
let shortest_path = path_between true leak_slice slice_start_vtx slice_leak_vtx in
|
||||
L.printf 1 "@\nshortest leak path:@\n%a" fmt_path (shortest_path, leak_vtx) ;
|
||||
let longest_path = path_between false leak_slice slice_start_vtx slice_leak_vtx in
|
||||
L.printf 1 "@\nlongest leak path:@\n%a" fmt_path (longest_path, leak_vtx) ;
|
||||
|
||||
("Shortest abstract path to Leak "^leak_id, shortest_path, fmt_ats_state) ::
|
||||
("Longest abstract path to Leak "^leak_id, longest_path, fmt_ats_state) ::
|
||||
traces
|
||||
) (Analysis.leaks results)
|
||||
in
|
||||
if Config.write_tt then Library.with_out "defect.tt" (write_defect_tt traces) ;
|
||||
false
|
||||
with Unsupported ->
|
||||
L.printf 0 "CEx: Unsupported transition" ;
|
||||
false
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Generation of counter-example trace for sdvdefect viewer *)
|
||||
|
||||
|
||||
val disprove : Analysis.t -> bool
|
||||
|
|
@ -0,0 +1,302 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Discovery of patterns for parametric inductive predicates *)
|
||||
|
||||
open Library
|
||||
|
||||
open Type
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
module S = Substitution
|
||||
open SYMBOLIC_HEAP
|
||||
open SymbolicHeap
|
||||
open Program
|
||||
|
||||
module L = (val Log.std Config.vDiscovery : Log.LOG)
|
||||
module LSH = (val Log.std Config.vSH : Log.LOG)
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Patterns
|
||||
============================================================================*)
|
||||
|
||||
(** Patn constructor support *)
|
||||
|
||||
let deref_typ ty =
|
||||
match Typ.desc ty with
|
||||
| Typ.Pointer(t) -> t
|
||||
| _ -> invalid_arg "Discovery.deref_typ"
|
||||
|
||||
|
||||
let name_of_path path =
|
||||
String.concat "." (List.rev_map Fld.name path)
|
||||
|
||||
let param_of_path path =
|
||||
let name = name_of_path path in
|
||||
let p = Var.gensym ("p"^name) Var.PointerSort in
|
||||
let f = Var.gensym ("f"^name) Var.PointerSort in
|
||||
let b = Var.gensym ("b"^name) Var.PointerSort in
|
||||
let n = Var.gensym ("n"^name) Var.PointerSort in
|
||||
(p, f, b, n)
|
||||
|
||||
let pt_of_path base typ cnts path =
|
||||
let loc = E.mkAdds base path in
|
||||
let off = Off.mkPath typ path in
|
||||
let cnt = try Some(List.assoc path cnts) with Not_found -> None in
|
||||
{Pt.loc; off; cnt}
|
||||
|
||||
let obj_of_typ typ cnts pts =
|
||||
let paths = Typ.all_offsets typ in
|
||||
let name =
|
||||
match paths with
|
||||
| [] -> "void"
|
||||
| (_,[],_)::_ -> "empty"
|
||||
| (_,[field],_)::_ -> name_of_path [field]
|
||||
| (_,_::prefix,_)::_ -> name_of_path prefix in
|
||||
let paths = if paths <> [] then paths else [((0,None), [], Typ.mkTop)] in
|
||||
let base = E.mkVar (Var.gensym name Var.PointerSort) in
|
||||
let pts =
|
||||
List.fold (fun (_,path,_) pts ->
|
||||
pt_of_path base typ cnts path :: pts
|
||||
) paths pts in
|
||||
(base, pts)
|
||||
|
||||
|
||||
let mk_sll id mk_body =
|
||||
L.printf 2 "Trying to add %s..." id ;
|
||||
(fun p -> L.shift_verb (-1) (fun () -> L.printf 2 "@[<hov 2>Adding %s =@ %a@]" id Patn.fmt p))
|
||||
<&
|
||||
let typ = Typ.find_by_name id |> Option.get in
|
||||
let (_,base,_), paths = List.take (fun _ -> true) (Typ.all_offsets typ) in
|
||||
let _pv, fv, _bv, nv = param_of_path (List.tl base) in
|
||||
let f, n = E.mkVar fv, E.mkVar nv in
|
||||
let us, eqs, cnts, pts = mk_body typ f n in
|
||||
let params, eqs, pts =
|
||||
List.fold_right (fun (_,path,_) ({prev; frnt; back; next}, eqs, pts) ->
|
||||
let _p', f', _b', n' = param_of_path path in
|
||||
( {prev; frnt= f'::frnt; back; next= n'::next}
|
||||
, E.mkEq (E.mkVar f') (E.mkAdds f path) ::
|
||||
E.mkEq (E.mkVar n') (E.mkAdds n path) :: eqs
|
||||
, pt_of_path f typ cnts path :: pts
|
||||
)
|
||||
) paths ({prev= []; frnt= []; back=[]; next= []}, eqs, pts) in
|
||||
let {prev; frnt; back; next} = params in
|
||||
let params = {prev; frnt= fv::frnt; back; next= nv::next} in
|
||||
let pts = pt_of_path f typ cnts base :: pts in
|
||||
let body = SH.Pf.star eqs (SH.PtS.star pts SH.emp) in
|
||||
Patn.mk ~name:id params
|
||||
(SH.exists_intro (Vars.diff (SH.fv body) (Vars.union us (Params.fv params)))
|
||||
body)
|
||||
|
||||
|
||||
let mk_dll id mk_body =
|
||||
L.printf 2 "Trying to add %s..." id ;
|
||||
(fun p -> L.shift_verb (-1) (fun () -> L.printf 2 "@[<hov 2>Adding %s =@ %a@]" id Patn.fmt p))
|
||||
<&
|
||||
let typ = Typ.find_by_name id |> Option.get in
|
||||
let (_,base,_), paths = List.take (fun _ -> true) (Typ.all_offsets typ) in
|
||||
let pv, fv, bv, nv = param_of_path (List.tl base) in
|
||||
let p, f, b, n = E.mkVar pv, E.mkVar fv, E.mkVar bv, E.mkVar nv in
|
||||
let us, eqs, cnts, pts = mk_body typ p f b n in
|
||||
let params, eqs, pts =
|
||||
List.fold_right (fun (_,path,_) ({prev; frnt; back; next}, eqs, pts) ->
|
||||
let p', f', b', n' = param_of_path path in
|
||||
( {prev= p'::prev; frnt= f'::frnt; back=b'::back; next= n'::next}
|
||||
, E.mkEq (E.mkVar p') (E.mkAdds p path) ::
|
||||
E.mkEq (E.mkVar f') (E.mkAdds f path) ::
|
||||
E.mkEq (E.mkVar b') (E.mkAdds b path) ::
|
||||
E.mkEq (E.mkVar n') (E.mkAdds n path) :: eqs
|
||||
, pt_of_path f typ cnts path :: pts
|
||||
)
|
||||
) paths ({prev= []; frnt= []; back=[]; next= []}, eqs, pts) in
|
||||
let {prev; frnt; back; next} = params in
|
||||
let params = {prev= pv::prev; frnt= fv::frnt; back=bv::back; next= nv::next} in
|
||||
let pts = pt_of_path f typ cnts base :: pts in
|
||||
let body = SH.Pf.star eqs (SH.PtS.star pts SH.emp) in
|
||||
Patn.mk ~name:id params
|
||||
(SH.exists_intro (Vars.diff (SH.fv body) (Vars.union us (Params.fv params)))
|
||||
body)
|
||||
|
||||
|
||||
(** Patn constructors *)
|
||||
|
||||
let mk_patn_sll id =
|
||||
mk_sll id (fun sll _f n ->
|
||||
let fFlink, _ = Fld.find_by_name sll "Flink" |> Option.get in
|
||||
let us = Vars.empty in
|
||||
let eqs = [] in
|
||||
let cnts = [([fFlink], n)] in
|
||||
let pts = [] in
|
||||
(us, eqs, cnts, pts)
|
||||
)
|
||||
|
||||
|
||||
let mk_patn_dll id =
|
||||
mk_dll id (fun dll p f b n ->
|
||||
let fFlink, _ = Fld.find_by_name dll "Flink" |> Option.get in
|
||||
let fBlink, _ = Fld.find_by_name dll "Blink" |> Option.get in
|
||||
let us = Vars.empty in
|
||||
let eqs = [E.mkEq f b] in
|
||||
let cnts = [([fFlink], n); ([fBlink], p)] in
|
||||
let pts = [] in
|
||||
(us, eqs, cnts, pts)
|
||||
)
|
||||
|
||||
|
||||
let mk_patn_crom_data id =
|
||||
mk_dll id (fun cd p f b n ->
|
||||
let fCromList, le = Fld.find_by_name cd "CromList" |> Option.get in
|
||||
let fFlink, _ = Fld.find_by_name le "Flink" |> Option.get in
|
||||
let fBlink, _ = Fld.find_by_name le "Blink" |> Option.get in
|
||||
let fBuffer, pvoid = Fld.find_by_name cd "Buffer" |> Option.get in
|
||||
let fpMdl, pmdl = Fld.find_by_name cd "pMdl" |> Option.get in
|
||||
let us = Vars.empty in
|
||||
let pts = [] in
|
||||
let mdl, pts = obj_of_typ (deref_typ pmdl) [] pts in
|
||||
let buffer, pts = obj_of_typ (deref_typ pvoid) [] pts in
|
||||
let eqs = [E.mkEq f b] in
|
||||
let cnts =
|
||||
[ ([fFlink;fCromList], n)
|
||||
; ([fBlink;fCromList], p)
|
||||
; ([fBuffer], buffer)
|
||||
; ([fpMdl], mdl)
|
||||
] in
|
||||
(us, eqs, cnts, pts)
|
||||
)
|
||||
|
||||
|
||||
let mk_patn_async_address_data id _devExt =
|
||||
mk_dll id (fun aad p f b n ->
|
||||
let fAsyncAddressList, le = Fld.find_by_name aad "AsyncAddressList" |> Option.get in
|
||||
let fFlink, _ = Fld.find_by_name le "Flink" |> Option.get in
|
||||
let fBlink, _ = Fld.find_by_name le "Blink" |> Option.get in
|
||||
let fBuffer, pvoid = Fld.find_by_name aad "Buffer" |> Option.get in
|
||||
let fAddressRange, par = Fld.find_by_name aad "AddressRange" |> Option.get in
|
||||
let fpMdl, pmdl = Fld.find_by_name aad "pMdl" |> Option.get in
|
||||
let us = Vars.empty in
|
||||
let pts = [] in
|
||||
let mdl, pts = obj_of_typ (deref_typ pmdl) [] pts in
|
||||
let addressRange, pts = obj_of_typ (deref_typ par) [] pts in
|
||||
let buffer, pts = obj_of_typ (deref_typ pvoid) [] pts in
|
||||
let eqs = [E.mkEq f b] in
|
||||
let cnts =
|
||||
[ ([fFlink;fAsyncAddressList], n)
|
||||
; ([fBlink;fAsyncAddressList], p)
|
||||
; ([fBuffer], buffer)
|
||||
; ([fAddressRange], addressRange)
|
||||
; ([fpMdl], mdl)
|
||||
] in
|
||||
(us, eqs, cnts, pts)
|
||||
)
|
||||
|
||||
|
||||
let mk_patn_isoch_detach_data id devExt =
|
||||
mk_dll id (fun idd p f b n ->
|
||||
let fIsochDetachList, le = Fld.find_by_name idd "IsochDetachList" |> Option.get in
|
||||
let fFlink, _ = Fld.find_by_name le "Flink" |> Option.get in
|
||||
let fBlink, _ = Fld.find_by_name le "Blink" |> Option.get in
|
||||
let fDeviceExtension, _ = Fld.find_by_name idd "DeviceExtension" |> Option.get in
|
||||
let us = Vars.singleton devExt in
|
||||
let pts = [] in
|
||||
let eqs = [E.mkEq f b] in
|
||||
let cnts =
|
||||
[ ([fFlink;fIsochDetachList], n)
|
||||
; ([fBlink;fIsochDetachList], p)
|
||||
; ([fDeviceExtension], E.mkVar devExt)
|
||||
] in
|
||||
(us, eqs, cnts, pts)
|
||||
)
|
||||
|
||||
|
||||
let mk_patn_isoch_resource_data id =
|
||||
mk_dll id (fun idd p f b n ->
|
||||
let fIsochResourceList, le = Fld.find_by_name idd "IsochResourceList" |> Option.get in
|
||||
let fFlink, _ = Fld.find_by_name le "Flink" |> Option.get in
|
||||
let fBlink, _ = Fld.find_by_name le "Blink" |> Option.get in
|
||||
let us = Vars.empty in
|
||||
let pts = [] in
|
||||
let eqs = [E.mkEq f b] in
|
||||
let cnts =
|
||||
[ ([fFlink;fIsochResourceList], n)
|
||||
; ([fBlink;fIsochResourceList], p)
|
||||
] in
|
||||
(us, eqs, cnts, pts)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Initialization
|
||||
============================================================================*)
|
||||
|
||||
(** Patn ids *)
|
||||
|
||||
(* SI: the AAD and IDD patterns are hard-coded to pick up the
|
||||
harness.h-generated SL_Context_DEVICE_EXTENSION device extension. *)
|
||||
let id_sll = "_SLL_ENTRY"
|
||||
let id_dll = "_LIST_ENTRY"
|
||||
let id_crom_data = "_CROM_DATA"
|
||||
let id_async_address_data = "_ASYNC_ADDRESS_DATA"
|
||||
let id_isoch_detach_data = "_ISOCH_DETACH_DATA"
|
||||
let id_isoch_resource_data = "_ISOCH_RESOURCE_DATA"
|
||||
|
||||
|
||||
(** patn.name->patn dictionary *)
|
||||
(* Only use after [initialize] has run. *)
|
||||
let patn_dict = ref []
|
||||
|
||||
let patn_dict_add (id,p) =
|
||||
patn_dict := (id,p) :: !patn_dict
|
||||
|
||||
|
||||
let _ = Initialize.register (fun {Prog.globals} ->
|
||||
L.incf 1 "( Discovery.init: adding patns to discovery list" ;
|
||||
L.decf 1 ") Discovery.init"
|
||||
$>
|
||||
let sl_context_var =
|
||||
let the_context_var =
|
||||
Vars.fold (fun v result ->
|
||||
if ("SL_Context_DEVICE_EXTENSION" = (Var.name v)) then (Some v) else result
|
||||
) globals None in
|
||||
match the_context_var with
|
||||
| Some(v) -> v
|
||||
| None ->
|
||||
L.printf 1 "no SL_Context declared." ;
|
||||
Var.gensym "DummySLContext" Var.PointerSort
|
||||
in
|
||||
try patn_dict_add (id_crom_data, mk_patn_crom_data id_crom_data)
|
||||
with Not_found -> () ;
|
||||
try patn_dict_add (id_async_address_data, mk_patn_async_address_data id_async_address_data sl_context_var)
|
||||
with Not_found -> () ;
|
||||
try patn_dict_add (id_isoch_detach_data, mk_patn_isoch_detach_data id_isoch_detach_data sl_context_var)
|
||||
with Not_found -> () ;
|
||||
try patn_dict_add (id_isoch_resource_data, mk_patn_isoch_resource_data id_isoch_resource_data)
|
||||
with Not_found -> () ;
|
||||
try patn_dict_add (id_sll, mk_patn_sll id_sll)
|
||||
with Not_found -> () ;
|
||||
try patn_dict_add (id_dll, mk_patn_dll id_dll)
|
||||
with Not_found -> () ;
|
||||
)
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Queries
|
||||
============================================================================*)
|
||||
|
||||
type result = Done | More of Patn.t * (unit -> result)
|
||||
|
||||
let discover _ =
|
||||
let rec aux = function
|
||||
| [] -> Done
|
||||
| (_,x) :: xl -> More(x, fun()-> aux xl)
|
||||
in
|
||||
aux !patn_dict
|
||||
|
||||
let fold fn q a =
|
||||
let rec fold_fn acc res =
|
||||
match res () with
|
||||
| Done -> acc
|
||||
| More(pat,res) -> fold_fn (fn pat acc) res
|
||||
in
|
||||
fold_fn a (fun()-> discover q)
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Discovery of patterns for parametric inductive predicates *)
|
||||
|
||||
open SymbolicHeap
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Discovery
|
||||
============================================================================*)
|
||||
|
||||
type result = Done | More of Patn.t * (unit -> result)
|
||||
|
||||
|
||||
val discover : XSH.t -> result
|
||||
|
||||
val fold : (Patn.t -> 'a -> 'a) -> XSH.t -> 'a -> 'a
|
||||
|
|
@ -0,0 +1,234 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Disjunctive Congruence Closure *)
|
||||
|
||||
open Library
|
||||
|
||||
open FORMULA
|
||||
open CONGRUENCE_RELATION
|
||||
|
||||
module LblMap = IntMap
|
||||
|
||||
module L = (val Log.std Config.vDCC : Log.LOG)
|
||||
|
||||
|
||||
|
||||
(* Timing =================================================================== *)
|
||||
|
||||
let cc_tmr = Timer.create "DCC leaves by congruence closure"
|
||||
let gie_tmr = Timer.create "DCC leaves by get_implied_equalities"
|
||||
|
||||
|
||||
|
||||
module Make
|
||||
(Frm: FORMULA)
|
||||
(CngRel: CONGRUENCE_RELATION
|
||||
with type exp := Frm.Exp.t
|
||||
and type exps := Frm.Exps.t) :
|
||||
sig
|
||||
|
||||
val dcc : (Frm.Exp.t->Frm.Exp.t->bool) -> ?dnf:bool -> ?init:CngRel.t -> Frm.t -> (CngRel.t * CngRel.t) LblMap.t
|
||||
|
||||
end = struct
|
||||
|
||||
open Expression
|
||||
(* module Exp = Frm.Exp *)
|
||||
(* module Exps = Frm.Exps *)
|
||||
(* module ExpMap = Frm.ExpMap *)
|
||||
|
||||
module Weights = struct
|
||||
include ExpMap
|
||||
let find e w = try find e w with Not_found -> 0
|
||||
end
|
||||
|
||||
|
||||
let cc_leaves leq dnf init f =
|
||||
Timer.start cc_tmr ; (fun _ -> Timer.stop cc_tmr) <&
|
||||
Frm.fold_dnf ~dnf
|
||||
(fun f ((cube,r),m) ->
|
||||
(* L.incf 0 "( map: %a" Frm.fmt f ; (fun _ -> L.decf 0 ") map") <& *)
|
||||
(* L.incf 0 "( map: %a" Frm.fmt f ; (fun ((_cube,r),(_m,_w)) -> L.decf 0 ") map: %a" CngRel.fmt r) <& *)
|
||||
let r =
|
||||
Frm.fold_rels
|
||||
(fun es r ->
|
||||
match es with
|
||||
| e::es -> List.fold (fun e' r -> CngRel.merge leq r e e') es r
|
||||
| _ -> r
|
||||
)
|
||||
(fun e f r -> CngRel.merge leq r e f)
|
||||
f r in
|
||||
let r =
|
||||
Frm.fold_nrels (fun e f r ->
|
||||
CngRel.split r e f
|
||||
) f r in
|
||||
((f::cube,r),m)
|
||||
)
|
||||
(fun ((cube,r),m) ->
|
||||
List.fold (fun f m ->
|
||||
if not (Frm.is_leaf f) then m
|
||||
else
|
||||
let l = Frm.lbl f in
|
||||
let s' = try CngRel.inter (fun _ _ -> true) (LblMap.find l m) r with Not_found -> r in
|
||||
(* L.printf 0 "red: %i" l ; *)
|
||||
(* L.printf 0 "red: %i@ %a" l CngRel.fmt s' ; *)
|
||||
LblMap.add l s' m
|
||||
) cube m
|
||||
)
|
||||
f ([], init) LblMap.empty
|
||||
|
||||
|
||||
let ctx = Pure.mk ()
|
||||
|
||||
let gie_leaves leq init f =
|
||||
Timer.start gie_tmr ; (fun _ -> Timer.stop gie_tmr) <&
|
||||
let init_eqs = CngRel.fold (fun e' e b -> Exp.mkEq e' e :: b) init []
|
||||
in
|
||||
let pure_f, lbl_to_prop = Frm.labeled_pure_consequences f
|
||||
in
|
||||
Pure.conjoin_weak ctx (Exp.mkAnd (Array.of_list (pure_f :: init_eqs)))
|
||||
;
|
||||
let m =
|
||||
Frm.fold_sp
|
||||
(fun f (lbls, carrier) ->
|
||||
(* L.printf 0 "dn: %a" Frm.fmt f ; *)
|
||||
let carrier =
|
||||
Frm.fold_rels
|
||||
(fun es z -> List.fold Exps.add es z)
|
||||
(fun e' e z -> Exps.add e' (Exps.add e z))
|
||||
f carrier in
|
||||
let lbls = Frm.lbl f :: lbls in
|
||||
(lbls, carrier)
|
||||
)
|
||||
(fun f (lbls, carrier) m ->
|
||||
(* L.printf 0 "up: @[[@[%a@]]@ %a@]" (List.fmt ";@ " Format.pp_print_int) lbls Frm.fmt f ; *)
|
||||
if not (Frm.is_leaf f) then m
|
||||
else
|
||||
let lbl = Frm.lbl f in
|
||||
let assumptions = Array.of_list (List.map (fun lbl -> IntMap.find lbl lbl_to_prop) lbls) in
|
||||
let cng = CngRel.implied_by leq init ctx assumptions carrier in
|
||||
LblMap.add lbl cng m
|
||||
)
|
||||
f ([], Exps.empty) LblMap.empty
|
||||
in
|
||||
Pure.clear ctx
|
||||
;
|
||||
m
|
||||
|
||||
|
||||
let dcc leq ?(dnf=true) ?(init=CngRel.empty) f =
|
||||
(* L.incf 0 "( dcc: %a" Frm.fmt f ; (fun _ -> L.decf 0 ") dcc") <& *)
|
||||
(* Refine preorder [cmp] to prefer w-heavier exps *)
|
||||
let init_reps = CngRel.representatives init
|
||||
in
|
||||
let leqr e f =
|
||||
match Exps.mem e init_reps, Exps.mem f init_reps with
|
||||
| true, false -> true
|
||||
| false, true -> false
|
||||
| _ -> leq e f
|
||||
in
|
||||
(* Compute strongest congruence relation forced by each leaf branch *)
|
||||
let m = cc_leaves leqr dnf init f
|
||||
in
|
||||
(* Re-express congruence relations for leaves using final weights *)
|
||||
let w =
|
||||
LblMap.fold (fun _lbl cng w ->
|
||||
Exps.fold (fun e' w ->
|
||||
let cls = CngRel.class_of cng e' in
|
||||
let cls_size = Exps.cardinal cls - 1 in
|
||||
Exps.fold (fun e w ->
|
||||
Weights.modify_add (fun old -> old + cls_size) e cls_size w
|
||||
) cls w
|
||||
) (CngRel.representatives cng) w
|
||||
) m Weights.empty
|
||||
in
|
||||
let leqw w e f =
|
||||
(* (fun o -> L.printf 0 "%a %s %a" Exp.fmt e (if o then "<=" else ">") Exp.fmt f) <& *)
|
||||
match Exps.mem e init_reps, Exps.mem f init_reps with
|
||||
| true, false -> true
|
||||
| false, true -> false
|
||||
| _ ->
|
||||
(Weights.find e w) > (Weights.find f w) || leq e f
|
||||
in
|
||||
let m = LblMap.map (fun r -> CngRel.union (leqw w) r r) m
|
||||
in
|
||||
assert(true$>(
|
||||
if not Config.dcc_gie || not Config.check_gie_vs_cc then () else
|
||||
let some_inconsis = ref false
|
||||
in
|
||||
let m0 =
|
||||
if Config.dcc_gie then
|
||||
LblMap.map (fun r -> CngRel.union (leqw w) r r) (gie_leaves leqr init f)
|
||||
else
|
||||
LblMap.empty
|
||||
in
|
||||
LblMap.iter (fun lbl cng1 ->
|
||||
let cng0 = LblMap.find lbl m0 in
|
||||
if CngRel.is_empty cng0 then
|
||||
some_inconsis := true
|
||||
else
|
||||
let missed_eqs cng0 cng1 =
|
||||
CngRel.fold (fun e' e eqs ->
|
||||
try
|
||||
if not (CngRel.mem_carrier e' cng1) || not (CngRel.mem_carrier e' cng1)
|
||||
|| (Exp.sort_of e' <> Exp.sort_of e)
|
||||
|| (CngRel.mem cng1 e' e)
|
||||
then eqs
|
||||
else Exp.mkEq e' e :: eqs
|
||||
with exn ->
|
||||
L.printf 0 "comparing get_implied_equalities vs congruence closure:@ @[%a@ %a@]"
|
||||
CngRel.fmt cng0 CngRel.fmt cng1 ;
|
||||
L.printf 0 "%a = %a" Exp.fmt e' Exp.fmt e ;
|
||||
raise exn
|
||||
) cng0 [] in
|
||||
let cc_missed = missed_eqs cng0 cng1 in
|
||||
let ie_missed = missed_eqs cng1 cng0 in
|
||||
if cc_missed <> [] || ie_missed <> [] then
|
||||
L.printf 0 "comparing get_implied_equalities vs congruence closure:@ @[%a@ %a@]"
|
||||
CngRel.fmt cng0 CngRel.fmt cng1 ;
|
||||
if cc_missed <> [] then L.printf 0 "cc missed: @[%a@]" (List.fmt ";@ " Exp.fmt) cc_missed ;
|
||||
if ie_missed <> [] then L.printf 0 "ie missed: @[%a@]" (List.fmt ";@ " Exp.fmt) ie_missed ;
|
||||
assert( cc_missed = [] && ie_missed = [] );
|
||||
) m ;
|
||||
));
|
||||
(* Compute congruence relations for internal labels from those for leaves *)
|
||||
let m =
|
||||
Frm.fold_sp
|
||||
(fun f lbls ->
|
||||
(* L.printf 0 "dn: %a" Frm.fmt f ; *)
|
||||
Frm.lbl f :: lbls)
|
||||
(fun f lbls m ->
|
||||
(* L.printf 0 "up: @[[@[%a@]]@ %a@]" (List.fmt ";@ " Format.pp_print_int) lbls Frm.fmt f ; *)
|
||||
match lbls with
|
||||
| _ :: l_parent :: _ ->
|
||||
let l = Frm.lbl f in
|
||||
let m_l = LblMap.find l m in
|
||||
let r' =
|
||||
try
|
||||
let m_p = LblMap.find l_parent m in
|
||||
(* Choose reps from deeper labels if possible *)
|
||||
let reps = Exps.union (CngRel.representatives m_l) (CngRel.representatives m_p) in
|
||||
let leq e f = (Exps.mem e reps) || not (Exps.mem f reps) in
|
||||
CngRel.inter leq m_l m_p
|
||||
with Not_found ->
|
||||
m_l
|
||||
in
|
||||
(* L.printf 0 "add: %i" l_parent ; *)
|
||||
(* L.printf 0 "add: %i@ %a" l_parent CngRel.fmt r' ; *)
|
||||
LblMap.add l_parent r' m
|
||||
| _ ->
|
||||
m
|
||||
)
|
||||
f [] m
|
||||
in
|
||||
(* Compute set of exps that are representatives in some relation *)
|
||||
let reps =
|
||||
LblMap.fold (fun _ r reps ->
|
||||
Exps.union (CngRel.representatives r) reps
|
||||
) m Exps.empty
|
||||
in
|
||||
(* Compute trimmed relation for each label *)
|
||||
LblMap.fold (fun l r m ->
|
||||
LblMap.add l (r, CngRel.restrict r reps) m
|
||||
) m LblMap.empty
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Disjunctive Transitive Closure *)
|
||||
|
||||
open Library
|
||||
|
||||
open FORMULA
|
||||
open CONGRUENCE_RELATION
|
||||
open TRANSITIVE_RELATION
|
||||
|
||||
module LblMap = IntMap
|
||||
|
||||
|
||||
module Make
|
||||
(Frm: FORMULA)
|
||||
(CngRel: CONGRUENCE_RELATION
|
||||
with type exp = Frm.Exp.t
|
||||
and type exps = Frm.Exps.t )
|
||||
(DisjCngClos: sig
|
||||
val dcc : Frm.t -> (CngRel.t * CngRel.t) LblMap.t end)
|
||||
(TransRel: TRANSITIVE_RELATION
|
||||
with type exp = Frm.Exp.t
|
||||
and type exps = Frm.Exps.t ) :
|
||||
sig
|
||||
|
||||
val dtc : Frm.t -> TransRel.t LblMap.t
|
||||
|
||||
end = struct
|
||||
|
||||
module Exp = Frm.Exp
|
||||
module Exps = Frm.Exps
|
||||
module ExpMap = Frm.ExpMap
|
||||
|
||||
|
||||
let dtc f =
|
||||
(* Compute disjunctive congruence closure *)
|
||||
let cm = DisjCngClos.dcc f
|
||||
in
|
||||
(* Compute strongest transitive and trimmed congruence closed relation forced by each leaf branch *)
|
||||
let m =
|
||||
Frm.fold_dnf
|
||||
(fun f ((cube,t),m) ->
|
||||
let l = Frm.lbl f in
|
||||
let _, r_trim = LblMap.find l cm in
|
||||
let t =
|
||||
Frm.fold_rels
|
||||
(fun es ->
|
||||
TransRel.add_scc
|
||||
(List.fold (fun e scc ->
|
||||
Exps.union (CngRel.class_of r_trim e) scc
|
||||
) es Exps.empty)
|
||||
)
|
||||
(fun e f t ->
|
||||
t
|
||||
|> TransRel.add_scc (CngRel.class_of r_trim e)
|
||||
|> TransRel.add_scc (CngRel.class_of r_trim f)
|
||||
|> TransRel.add (e,f)
|
||||
)
|
||||
f t in
|
||||
((f::cube, t), m)
|
||||
)
|
||||
(fun ((cube,t),m) ->
|
||||
(* For all the clauses that mention a particular sub formula,
|
||||
calculate the intersection of the relations *)
|
||||
List.fold (fun f m ->
|
||||
if not (Frm.is_leaf f) then
|
||||
m
|
||||
else
|
||||
LblMap.modify_add (fun t0 -> TransRel.inter t0 t) (Frm.lbl f) t m
|
||||
) cube m
|
||||
)
|
||||
f ([], TransRel.empty) LblMap.empty
|
||||
in
|
||||
(* Compute relations for internal labels from those for leaves *)
|
||||
Frm.fold_sp
|
||||
(fun f lbls -> Frm.lbl f :: lbls)
|
||||
(fun f lbls m ->
|
||||
match lbls with
|
||||
| _ :: l_parent :: _ ->
|
||||
let l = Frm.lbl f in
|
||||
let t = LblMap.find l m in
|
||||
LblMap.modify_add (fun t0 -> TransRel.inter t t0) l_parent t m
|
||||
| _ ->
|
||||
m
|
||||
)
|
||||
f [] m
|
||||
|
||||
end
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,290 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Expressions *)
|
||||
|
||||
open Library
|
||||
|
||||
open Type
|
||||
open Variable
|
||||
|
||||
val stats : unit -> int * int * int * int * int * int
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Exp
|
||||
============================================================================*)
|
||||
|
||||
module Exp : sig
|
||||
|
||||
type op1 = Allocd | Not | ZMin
|
||||
type op2 = ZLt | ZLe | ZGt | ZGe | ZDiv | ZRem | ZMod
|
||||
type op3 = Ite
|
||||
type opN = Distinct | And | Or | ZAdd | ZMul | UFun of string
|
||||
|
||||
type t = t_desc HashCons.hc
|
||||
|
||||
and t_desc = private
|
||||
| Var of Var.t
|
||||
(* Pointer expressions *)
|
||||
| App of t * t (** Application of pointer expressions *)
|
||||
| Nil (** Constant symbol for NULL pointer *)
|
||||
| Add of Fld.t (** Function symbol for adding field to pointer *)
|
||||
| Sub of Fld.t (** Function symbol for subtracting field from pointer *)
|
||||
| Idx (** Function symbol for indexing into an array *)
|
||||
(* Offset expressions *)
|
||||
| Bas of Typ.t (** Constant symbol for empty offset (from pointer of type) *)
|
||||
(* Integer, Boolean and String expressions *)
|
||||
| Eq of t * t
|
||||
| Num of int64
|
||||
| Str of string
|
||||
| Op1 of op1 * t_desc
|
||||
| Op2 of op2 * t_desc * t_desc
|
||||
| Op3 of op3 * t_desc * t_desc * t_desc
|
||||
| OpN of opN * t_desc array
|
||||
|
||||
val desc : t -> t_desc
|
||||
(** [desc e] is the descriptor named by expression [e] *)
|
||||
|
||||
val name : t_desc -> t
|
||||
(** [name d] is the unique expression name of descriptor [d] *)
|
||||
|
||||
|
||||
(* Sort operations ======================================================== *)
|
||||
|
||||
val sort_of : t -> Var.sort
|
||||
|
||||
val is_pointer : t -> bool
|
||||
val is_integer : t -> bool
|
||||
val is_boolean : t -> bool
|
||||
val is_offset : t -> bool
|
||||
|
||||
|
||||
(* Constructors =========================================================== *)
|
||||
|
||||
exception IllSorted of t_desc
|
||||
|
||||
val mkVar : Var.t -> t
|
||||
|
||||
(* Pointer expressions *)
|
||||
val mkApp : t -> t -> t
|
||||
(** [mkApp f a] constructs an expression equivalent to [App(f,a)] *)
|
||||
val getApp : t -> (t * t) option
|
||||
(** [getApp (App(f,a))] is [Some(f,a)], and [None] in other cases *)
|
||||
val nil : t
|
||||
val mkAdd : t -> Fld.t -> t
|
||||
val mkSub : t -> Fld.t -> t
|
||||
val mkAdds : t -> Fld.t list -> t
|
||||
(** [mkAdds e [fN; ...; f2; f1]] is [e+f1+f2+...+fN] *)
|
||||
val mkSubs : t -> Fld.t list -> t
|
||||
(** [mkSubs e [fN; ...; f2; f1]] is [e-fN-...-f2-f1] *)
|
||||
val invert : t -> t option
|
||||
(** [invert] transforms [Add(o)] to [Sub(o)] and vice versa, and returns
|
||||
[None] in other cases *)
|
||||
val mkIdx : t -> t -> t
|
||||
(** [mkIdx a i] creates an expression denoting the address of element [i] of array [a] *)
|
||||
|
||||
(* Offset expressions *)
|
||||
val mkBas : Typ.t -> t
|
||||
|
||||
(* Integer expressions *)
|
||||
val zero : t
|
||||
val one : t
|
||||
val mkNum : int64 -> t
|
||||
val mkStr : string -> t
|
||||
val mkZMin : t -> t
|
||||
val mkZDiv : t -> t -> t
|
||||
val mkZRem : t -> t -> t
|
||||
val mkZMod : t -> t -> t
|
||||
val mkZAdd : t array -> t
|
||||
val mkZSub : t array -> t
|
||||
val mkZMul : t array -> t
|
||||
val mkUFun : string -> t array -> t
|
||||
|
||||
(* Boolean expressions *)
|
||||
val tt : t
|
||||
val ff : t
|
||||
|
||||
val mkNot : t -> t
|
||||
val mkAnd : t array -> t
|
||||
val mkOr : t array -> t
|
||||
val mkImp : t -> t -> t
|
||||
val mkIff : t -> t -> t
|
||||
val mkXor : t -> t -> t
|
||||
|
||||
val mkEq : t -> t -> t
|
||||
val mkDq : t -> t -> t
|
||||
val mkDistinct : t array -> t
|
||||
val mkAllocd : t -> t
|
||||
|
||||
val mkZLt : t -> t -> t
|
||||
val mkZLe : t -> t -> t
|
||||
val mkZGt : t -> t -> t
|
||||
val mkZGe : t -> t -> t
|
||||
|
||||
(* Generic expressions *)
|
||||
val mkIte : t -> t -> t -> t
|
||||
|
||||
(* Conversions *)
|
||||
val convert : Var.sort -> t -> t option
|
||||
|
||||
val mkOp1 : op1 -> t_desc -> t
|
||||
val mkOp2 : op2 -> t_desc -> t_desc -> t
|
||||
val mkOp3 : op3 -> t_desc -> t_desc -> t_desc -> t
|
||||
val mkOpN : opN -> t_desc array -> t
|
||||
|
||||
|
||||
(* Queries ================================================================ *)
|
||||
|
||||
(* val size : t -> int *)
|
||||
|
||||
(* val is_atomic : t -> bool *)
|
||||
|
||||
val fv : t -> Vars.t
|
||||
|
||||
(* val diff_inter_diff : t -> t -> t * t * t *)
|
||||
|
||||
(* val partition : (t -> bool) -> t -> t * t *)
|
||||
|
||||
val remove : (t_desc -> bool) -> t -> t
|
||||
|
||||
|
||||
(* Maps and Folds ========================================================= *)
|
||||
|
||||
(** [kmap_fold before after e sa0 la0] simultaneously maps and folds overa
|
||||
the structure of [e], in continuation-passing style.
|
||||
|
||||
Each subexpression [x] of [e] is passed to [before] prior to traversing
|
||||
its children.
|
||||
|
||||
Calling the continuation [k] traverses [x]'s children in right-to-left
|
||||
order. When calling [k] the structural accumulator [sa] and linear
|
||||
accumulator [la] can be updated. After traversing [x]'s children, the
|
||||
expression [x'] returned by [before] is passed to [after].
|
||||
|
||||
The structural accumulator [sa] is accumulated over the structure of the
|
||||
expression, that is, it has been updated by [before] for each
|
||||
subexpression of [e] that is a proper superexpression of [x]. The
|
||||
linear accumulator [la] is accumulated over all subexpressions, that is,
|
||||
it has been updated by [before] and passed to [after] for each
|
||||
subexpression earlier than [x] in the right-to-left traversal.
|
||||
*)
|
||||
(* val kmap_fold : *)
|
||||
(* (('sa->'la-> 'a) -> t -> 'sa->'la-> t * 'la) -> *)
|
||||
(* (t -> 'sa -> 'la-> 'a) -> *)
|
||||
(* t -> 'sa -> 'la-> t * 'la *)
|
||||
|
||||
(** [kfold] is like [kmap_fold] but does not transform, only accumulates. *)
|
||||
(* val kfold : *)
|
||||
(* (('sa->'la-> 'a) -> t -> 'sa->'la-> 'la) -> *)
|
||||
(* (t -> 'sa->'la-> 'a) -> *)
|
||||
(* t -> 'sa->'la-> 'la *)
|
||||
|
||||
(** [kmap] is like [kmap_fold] but does not accumulate, only transforms. *)
|
||||
(* val kmap : ((unit -> t) -> t -> t) -> t -> t *)
|
||||
|
||||
(** [pmap_fold fn e z] performs a pre-order traversal of [e] which descends
|
||||
into each subexpression [d] of [e] only if [fn d z] returns [None]. *)
|
||||
(* val pmap_fold : (t -> 'a -> (t * 'a) option) -> t -> 'a -> t * 'a *)
|
||||
|
||||
(** [pfold] is like [pmap_fold] but does not transform, only accumulates. *)
|
||||
(* val pfold : (t -> 'a -> 'a option) -> t -> 'a -> 'a *)
|
||||
|
||||
(** [pmap] is like [pmap_fold] but does not accumulate, only transforms. *)
|
||||
val pmap : (t -> t option) -> t -> t
|
||||
|
||||
(** [map_fold fn e z] performs a standard post-order traversal of [e]. *)
|
||||
(* val map_fold : (t -> 'a -> t * 'a) -> t -> 'a -> t * 'a *)
|
||||
|
||||
(** [fold] is like [map_fold] but does not transform, only accumulates. *)
|
||||
val fold : (t -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
|
||||
val fold_sp : (t -> 's -> 's) -> (t -> 's -> 'p -> 'p) -> t -> 's -> 'p -> 'p
|
||||
|
||||
(** [map] is like [map_fold] but does not accumulate, only transforms. *)
|
||||
val map : (t -> t) -> t -> t
|
||||
|
||||
(** the [*_unord] operations are similar, but use an extended definition of
|
||||
subexpression, where the subexpressions of an offset include every
|
||||
unordered subset of the component fields. *)
|
||||
(* val pmap_unord : (t -> t option) -> t -> t *)
|
||||
|
||||
(* val fold_unord : (t -> 'a -> 'a) -> t -> 'a -> 'a *)
|
||||
|
||||
|
||||
val equal : t -> t -> bool
|
||||
val compare : t -> t -> int
|
||||
val hash : t -> int
|
||||
|
||||
val fmt : t formatter
|
||||
|
||||
val fmtp : Var.fxt -> t formatter
|
||||
|
||||
val fmt_caml : t formatter
|
||||
end
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Off
|
||||
============================================================================*)
|
||||
|
||||
module Off : sig
|
||||
|
||||
type t = private Exp.t
|
||||
|
||||
type desc = Var of Var.t | Path of Typ.t * Fld.t list
|
||||
|
||||
val mk : Exp.t -> t
|
||||
(** [mk] constructs an offset from an expression representing an offset.
|
||||
Raises [Assert_failure] if argument does not satisfy [Exp.is_offset]. *)
|
||||
|
||||
val mkVar : Var.t -> t
|
||||
(** [mkVar] constructs a variable offset. *)
|
||||
|
||||
val mkPath : Typ.t -> Fld.t list -> t
|
||||
(** [mkPath] constructs a literal offset from an access path
|
||||
[\[fN; ...; f2; f1\]] through type [ty] where each [fI] is a
|
||||
member of the type containing [fI-1]. *)
|
||||
|
||||
val desc : t -> desc
|
||||
(** [desc] returns the represented variable or access path *)
|
||||
|
||||
val fv : t -> Vars.t
|
||||
|
||||
val is_base : t -> Typ.t option
|
||||
(** [is_base o] returns the type [o] is an identity offset for, or [None] if [o] is not an identity
|
||||
offset. *)
|
||||
|
||||
val equal : t -> t -> bool
|
||||
val compare : t -> t -> int
|
||||
|
||||
val fmt : t formatter
|
||||
val fmtp : Var.fxt -> t formatter
|
||||
val fmt_caml : t formatter
|
||||
|
||||
end
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Collections
|
||||
============================================================================*)
|
||||
|
||||
module Exps : sig
|
||||
include Set.S with type elt = Exp.t
|
||||
|
||||
val fv : t -> Vars.t
|
||||
|
||||
(* val pfold : (Exp.t -> 'a -> 'a option) -> t -> 'a -> 'a *)
|
||||
|
||||
val fmt_sep : (unit,Format.formatter,unit)format -> t formatter
|
||||
val fmt : t formatter
|
||||
end
|
||||
|
||||
module Expss : (Set.S with type elt = Exps.t)
|
||||
|
||||
module ExpMap : (Map.S with type key = Exp.t)
|
||||
|
||||
module ExpMMap : (MultiMap.S with type k = Exp.t
|
||||
and type v = Exp.t
|
||||
and type vs = Exps.t)
|
||||
|
||||
module ExpHMap : (HashMap.S with type key = Exp.t)
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
module type FLD = sig
|
||||
type typ
|
||||
|
||||
type t
|
||||
|
||||
val off : t -> int * int option
|
||||
val id : t -> int
|
||||
val name : t -> string
|
||||
val typ : t -> typ
|
||||
|
||||
val is_first : t -> bool
|
||||
|
||||
val compare : t -> t -> int
|
||||
val equal : t -> t -> bool
|
||||
val hash : t -> int
|
||||
|
||||
val mk : int * int option -> string -> t
|
||||
(** [mk offset name] creates a fresh field for [offset] and name based on [name]. *)
|
||||
|
||||
val fmt : t formatter
|
||||
val fmt_caml : t formatter
|
||||
|
||||
val marshal : out_channel -> unit
|
||||
val unmarshal : in_channel -> unit
|
||||
|
||||
val unsafe_create : int -> int * int option -> string -> typ -> t
|
||||
|
||||
val find_by_name : typ -> string -> (t * typ) option
|
||||
(** [find_by_name ty name] returns the member of [ty] named [name]. *)
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Signatures for formulas used by congruence and transitive closure *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
module type EXP = sig
|
||||
|
||||
include OrderedType
|
||||
|
||||
val mkApp : t -> t -> t
|
||||
(** [mkApp f a] constructs [App(f,a)] *)
|
||||
|
||||
val getApp : t -> (t * t) option
|
||||
(** [getApp (App(f,a))] is [Some(f,a)], and [None] in other cases *)
|
||||
|
||||
val invert : t -> t option
|
||||
(** [invert] transforms [Add(o)] to [Sub(o)] and vice versa, and returns
|
||||
[None] in other cases *)
|
||||
|
||||
val fmt : t formatter
|
||||
|
||||
end
|
||||
|
||||
|
||||
module type FORMULA = sig
|
||||
|
||||
module Exp: (EXP with type t = Expression.Exp.t)
|
||||
module Exps: Set.S with type elt = Exp.t and type t = Expression.Exps.t
|
||||
module ExpMap: Map.S with type key = Exp.t and type 'a t = 'a Expression.ExpMap.t
|
||||
(* module Exp: EXP *)
|
||||
(* module Exps: Set.S with type elt = Exp.t *)
|
||||
(* module ExpMap: Map.S with type key = Exp.t *)
|
||||
|
||||
type t
|
||||
|
||||
val lbl : t -> int
|
||||
(** [lbl f] is the label of the root of formula [f] *)
|
||||
|
||||
val is_leaf : t -> bool
|
||||
|
||||
val fold_rels : (Exp.t list -> 'z -> 'z) -> (Exp.t -> Exp.t -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
(** [fold_rels] folds over related pairs of expressions, first
|
||||
function takes a strongly connected component, the second
|
||||
individual edges. *)
|
||||
|
||||
val fold_nrels : (Exp.t -> Exp.t -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
(** [fold_nrels] folds over provably unrelated pairs of expressions. *)
|
||||
|
||||
val fold_sp : (t -> 's -> 's) -> (t -> 's -> 'p -> 'p) -> t -> 's -> 'p -> 'p
|
||||
|
||||
val fold_dnf : ?dnf:bool -> (t -> 'c*'d -> 'c*'d) -> ('c*'d -> 'd) -> t -> 'c->'d -> 'd
|
||||
(** The disjunctive traversal of a formula, [fold_dnf m r f c d], is a generalization of incremental
|
||||
conversion to disjunctive-normal form that accumulates an abstract conjunction [m] over each cube, and
|
||||
accumulates an abstract disjunction [r] over the clauses. For example:
|
||||
[fold_dnf m r (f1 * ((f2 * f3) \/ f4)) c d =
|
||||
let c,d = m f1 (c,d) in r (m f4 (c, r (m (f2 * f3) (c,d))))]
|
||||
*)
|
||||
|
||||
val labeled_pure_consequences : t -> Exp.t * Exp.t IntMap.t
|
||||
|
||||
val fmt : t formatter
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Heuristic for localization of analysis of procedure calls *)
|
||||
|
||||
(*
|
||||
Calculate footprint and frame for [{ call } proc(actuals)].
|
||||
|
||||
1. Let RG(p) = set of globals "relevant" to proc. A global is relevant to
|
||||
proc if it appears in proc's body or in the body of any procedure that is in
|
||||
the static call-graph beginning at proc.
|
||||
|
||||
2. Then the principal *-conjunction of call is split into footprint * frame
|
||||
such that frame includes every spatial subformula that contains a may-alloc
|
||||
which is not reachable from RG(p) \cup actuals.
|
||||
*)
|
||||
|
||||
|
||||
(**/**)
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
open Program
|
||||
open SymbolicHeap
|
||||
(**/**)
|
||||
|
||||
module L = (val Log.std Config.vFrame : Log.LOG)
|
||||
let frame_tmr = Timer.create "Frame.footprint"
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Entry points.
|
||||
============================================================================*)
|
||||
|
||||
let footprint call callee actuals =
|
||||
Timer.start frame_tmr; assert(true$>(
|
||||
L.incf 1 "( footprint:@ %a@ %a(%a)" XSH.fmt call Proc.Id.fmt callee.Proc.id (List.fmt ",@ " Var.fmt) actuals ));
|
||||
(fun (foot,frame) ->
|
||||
Timer.stop frame_tmr ; assert(true$>(
|
||||
L.decf 1 ") footprint:@[%a@],@ frame:@[%a@]" XSH.fmt foot XSH.fmt frame )))
|
||||
<&
|
||||
let exps_of_vars vv =
|
||||
Vars.fold (fun v ee -> Exps.add (E.mkVar v) ee) vv Exps.empty
|
||||
in
|
||||
let actuals = List.fold (fun a actls -> Exps.add (Exp.mkVar a) actls) actuals Exps.empty
|
||||
in
|
||||
let xs, call = XSH.exists_bind (Vars.union (XSH.fv call) (Exps.fv actuals)) call
|
||||
in
|
||||
let callee_globals = exps_of_vars callee.Proc.accessed
|
||||
in
|
||||
let roots = Exps.union callee_globals actuals
|
||||
in
|
||||
let is_reachable = Reachability.is_reachable (fun e -> Exps.mem e roots) call call
|
||||
in
|
||||
(* frame away any spatial subformula that includes an unreachable may-alloc *)
|
||||
let footprint, frame =
|
||||
SH.partition (function
|
||||
| SH.Pt({Pt.loc}) ->
|
||||
is_reachable loc
|
||||
| SH.Ls(ls) ->
|
||||
(* Format.printf "List %a reachable?@\n" Ls.fmt ls; *)
|
||||
let res = List.exists is_reachable (Ls.may_allocs ls) in
|
||||
(* Format.printf "List %a reachable %b@\n" Ls.fmt ls res; *)
|
||||
res
|
||||
| SH.Dj(dj) ->
|
||||
Dj.for_all (fun dt -> Exps.exists is_reachable (SH.may_allocs dt)) dj
|
||||
) call
|
||||
in
|
||||
(SH.exists_intro xs footprint, SH.exists_intro xs frame)
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Heuristic for localization of analysis of procedure calls *)
|
||||
|
||||
open Variable
|
||||
open Program
|
||||
open SymbolicHeap
|
||||
|
||||
|
||||
(** For a procedure call [{ call } proc(actuals)],
|
||||
[footprint call proc actuals] is a pair ([footprint],[frame]) such that
|
||||
1. [footprint] is a sub-heap of [call] that over-approximates the
|
||||
footprint of the call; and
|
||||
2. ([footprint] * [frame]) = [call].
|
||||
*)
|
||||
val footprint : XSH.t -> Proc.t -> Var.t list -> XSH.t * XSH.t
|
||||
|
||||
val frame_tmr : Timer.t
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open Library
|
||||
|
||||
open Program
|
||||
|
||||
module L = (val Log.std Config.vFE : Log.LOG)
|
||||
|
||||
|
||||
let _ = try (
|
||||
(* turn on backtrace printing in debug mode *)
|
||||
assert(true$> Printexc.record_backtrace true );
|
||||
|
||||
(* Set a handler for Ctrl-C. *)
|
||||
Sys.catch_break true ;
|
||||
|
||||
L.printf 1 "%s@." (String.concat " " (Array.to_list Sys.argv)) ;
|
||||
Pervasives.flush_all () ;
|
||||
|
||||
if Config.version_only then (
|
||||
|
||||
Printf.printf "SLAyer frontend %s" Version.version ;
|
||||
|
||||
exit 0
|
||||
|
||||
) else (
|
||||
|
||||
let program = Frontend_esp.program_of_file Config.filenames in
|
||||
|
||||
if Config.write_cfg then Prog.write_dot Config.testname ".fe.cfg.dot" program ;
|
||||
|
||||
let program = if Config.norm_in_frontend then TransformProgram.normalize program else program in
|
||||
|
||||
Library.with_out_bin (Config.testname^".sil") Prog.marshal program
|
||||
|
||||
)
|
||||
) with exc ->
|
||||
if Config.raise_exceptions then (
|
||||
prerr_endline (Printexc.to_string exc) ;
|
||||
raise exc
|
||||
) else (
|
||||
print_endline ("\nRESULT: Internal Error: "^(Printexc.to_string exc)) ;
|
||||
flush_all () ;
|
||||
exit 1
|
||||
)
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,35 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Mutable edge- and vertex-labelled multi-graphs *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
module type GRAPH = Graph_sig.GRAPH
|
||||
|
||||
module Make
|
||||
(Index: sig
|
||||
type t
|
||||
val compare: t -> t -> int
|
||||
val equal: t -> t -> bool
|
||||
val hash: t -> int
|
||||
val fmt : t formatter
|
||||
end)
|
||||
(VertexLabel: sig
|
||||
type t
|
||||
val compare: t -> t -> int
|
||||
val equal: t -> t -> bool
|
||||
val fmt : t formatter
|
||||
end)
|
||||
(EdgeLabel: sig
|
||||
type t
|
||||
val compare: t -> t -> int
|
||||
val equal : t -> t -> bool
|
||||
val fmt : t formatter
|
||||
end)
|
||||
:
|
||||
(GRAPH
|
||||
with type index = Index.t
|
||||
and type v_label = VertexLabel.t
|
||||
and type e_label = EdgeLabel.t
|
||||
)
|
||||
|
|
@ -0,0 +1,191 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open Library
|
||||
|
||||
(** Signature for Graph *)
|
||||
|
||||
|
||||
module type GRAPH = sig
|
||||
|
||||
type index
|
||||
type v_label
|
||||
type e_label
|
||||
type graph
|
||||
|
||||
module Vertex : sig
|
||||
type t
|
||||
val compare : t -> t -> int
|
||||
val equal : t -> t -> bool
|
||||
val hash : t -> int
|
||||
val fmt : t formatter
|
||||
end
|
||||
type vertex = Vertex.t
|
||||
|
||||
(** sets of vertices *)
|
||||
module VertexISet : (ImperativeSet.S with type v = vertex)
|
||||
module VertexSet : (Set.S with type elt = vertex)
|
||||
|
||||
(** multi-maps from vertices (to edge labels) *)
|
||||
module VertexIMap : (ImperativeMap.S with type key = vertex)
|
||||
module VertexMap : (Map.S with type key = vertex)
|
||||
|
||||
val create : unit -> graph
|
||||
val clear : graph -> unit
|
||||
|
||||
val index_of : vertex -> index
|
||||
val label_of : vertex -> v_label
|
||||
|
||||
val in_degree : vertex -> int
|
||||
val out_degree : vertex -> int
|
||||
|
||||
val iter_preds : (vertex -> e_label -> unit) -> vertex -> unit
|
||||
val iter_succs : (vertex -> e_label -> unit) -> vertex -> unit
|
||||
|
||||
val fold_preds : (vertex -> e_label -> 'a -> 'a) -> vertex -> 'a -> 'a
|
||||
val fold_succs : (vertex -> e_label -> 'a -> 'a) -> vertex -> 'a -> 'a
|
||||
|
||||
val predecessors : vertex -> (vertex * e_label) list
|
||||
val successors : vertex -> (vertex * e_label) list
|
||||
|
||||
val vertices_for : graph -> index -> vertex list
|
||||
|
||||
val roots : graph -> vertex list
|
||||
|
||||
(** [mem_vertex g v] tests if [g] contains vertex [v] *)
|
||||
val mem_vertex : graph -> vertex -> bool
|
||||
|
||||
(** [add_vertex g (k,l)] adds and returns a vertex for [(k,l)] to [g], unless
|
||||
there already is one, in which case the existing vertex is returned *)
|
||||
val add_vertex : graph -> index * v_label -> vertex
|
||||
|
||||
(** [remove_vertex g v] removes [v] (which must exist) if it is
|
||||
disconnected, and any other non-rooted vertices that thereby get
|
||||
disconnected *)
|
||||
val remove_vertex : graph -> vertex -> unit
|
||||
|
||||
(** [replace_vertex g new_lab old_trg new_trg] swing all incoming edges to
|
||||
[old_trg] to [new_trg] *)
|
||||
val replace_vertex : graph -> (e_label -> e_label) -> vertex -> vertex -> unit
|
||||
|
||||
(** [relabel_vertex g v l] changes the label of [v] to [l], removing [v] from [g] and returning the new
|
||||
vertex, PROVIDED the old and new labels compare equal according to the [VertexLabel.equal] function
|
||||
passed to [Graph.Make]. *)
|
||||
val relabel_vertex : graph -> vertex -> v_label -> vertex
|
||||
|
||||
(** [root_vertex g v] marks [v] as "rooted" so that it will not be removed
|
||||
if it becomes disconnected *)
|
||||
val root_vertex : graph -> vertex -> unit
|
||||
|
||||
(** [unroot_vertex g v] unmarks [v] as "rooted" so that it will be removed
|
||||
if it becomes disconnected *)
|
||||
val unroot_vertex : graph -> vertex -> unit
|
||||
|
||||
(** [remove_unreachable g] removes all vertices not reachable from a root. *)
|
||||
val remove_unreachable : graph -> unit
|
||||
|
||||
(** [iter_vertices_index fn g k] applies [fn] to every vertex of [g] with
|
||||
index [k] *)
|
||||
val iter_vertices_index : (vertex -> unit) -> graph -> index -> unit
|
||||
|
||||
(** [iter_vertices fn g] applies [fn] to every vertex of [g] *)
|
||||
val iter_vertices : (vertex -> unit) -> graph -> unit
|
||||
|
||||
(** [fold_vertices_index fn g k] folds [fn] over every vertex of [g] with index [k] *)
|
||||
val fold_vertices_index : (vertex -> 'a -> 'a) -> graph -> index -> 'a -> 'a
|
||||
|
||||
(** [fold_vertices fn g acc] folds [fn] over every vertex of [g] *)
|
||||
val fold_vertices : (vertex -> 'a -> 'a) -> graph -> 'a -> 'a
|
||||
|
||||
(** [mem_edge g src label trg] tests if [g] contains an edge from [src] to
|
||||
[trg] labeled [label] *)
|
||||
val mem_edge : graph -> vertex -> e_label -> vertex -> bool
|
||||
|
||||
(** [add_edge g src label trg] adds an edge from [src] to [trg] with label
|
||||
[label] *)
|
||||
val add_edge : graph -> vertex -> e_label -> vertex -> unit
|
||||
|
||||
(** [remove_edge g src label trg] removes the edge (which must exist) from
|
||||
[src] to [trg] labeled [label] *)
|
||||
val remove_edge : graph -> vertex -> e_label -> vertex -> unit
|
||||
|
||||
(** [collapse_edge_pre g src label trg] swings all outgoing edges of [trg] to [src] *)
|
||||
val collapse_edge_pre : graph -> vertex -> e_label -> vertex -> unit
|
||||
|
||||
(** [collapse_edge_post g src label trg] swings all incoming edges to [src] to [trg] *)
|
||||
val collapse_edge_post : graph -> vertex -> e_label -> vertex -> unit
|
||||
|
||||
(** [iter_edges vertex_fn edge_fn g root] applies [vertex_fn] to every
|
||||
vertex reachable from [root] in [g], and [edge_fn] to every edge of [g]
|
||||
between those vertices *)
|
||||
val iter_edges : (vertex->unit) -> (vertex*e_label*vertex->unit) -> graph -> index -> unit
|
||||
|
||||
(** [fold_edges vertex_fn edge_fn g root z] accumulates [vertex_fn] over every vertex reachable from [root]
|
||||
in [g], and [edge_fn] over every edge of [g] between those vertices. *)
|
||||
val fold_edges : (vertex -> 'z -> 'z) -> (vertex * e_label * vertex -> 'z -> 'z) -> graph -> index -> 'z -> 'z
|
||||
|
||||
(** [identify_vertices g] returns a map that associate a unique integer to
|
||||
each vertex of [g] *)
|
||||
val identify_vertices : graph -> int VertexIMap.t
|
||||
|
||||
(** [cutpoints v] returns a set of cutpoints of the graph reachable from [v]. *)
|
||||
val cutpoints : vertex -> VertexSet.t
|
||||
|
||||
(** [bfs g s] does a breadth-first search of [g] from [s]. Returns the
|
||||
distance and predecessor results. *)
|
||||
val bfs : graph -> vertex -> (int VertexIMap.t * ((vertex*e_label) option VertexIMap.t))
|
||||
|
||||
(** [dfs_iter next forwards pre post vs] traverses depth-first from
|
||||
each elemtent of [vs], presenting vertices to [pre] in preorder,
|
||||
and to [post] in postorder. It calls [next] each time it moves
|
||||
to the next entry in [vs]. If [forwards]=true then it walks
|
||||
forwards, otherwise it walks backwards in the graph. By default
|
||||
[forwards] is true, and [next] does nothing.*)
|
||||
val dfs_iter : ?next:(unit->unit) -> ?forwards:bool -> (vertex -> unit) -> (vertex -> unit) -> vertex list -> unit
|
||||
|
||||
(** [dfs v] returns a list of vertices reachable from [v] in preorder, a list of vertices in postorder, and
|
||||
functions mapping vertices to their position in the preorder and in the postorder. *)
|
||||
val dfs : vertex -> vertex list * vertex list * (vertex -> int) * (vertex -> int)
|
||||
|
||||
(** [scc g] returns a map, that maps each vertex to the list of
|
||||
vertices in its strongly connected component. *)
|
||||
val scc : graph -> (vertex list) VertexMap.t
|
||||
|
||||
(** [dominance_frontier g s] gives the dfset and dominator tree of [g]
|
||||
[dom n m] is the dominator relationship
|
||||
[parent_of n] is the immediate dominator of n
|
||||
[children_of n] is the set of vertices that are dominated by n *)
|
||||
val dominance_frontier :
|
||||
graph -> vertex -> (VertexISet.t VertexIMap.t) * (* dfset *)
|
||||
(vertex -> vertex -> bool) * (* dom *)
|
||||
(vertex -> vertex option) * (* parent_of *)
|
||||
(vertex -> VertexISet.t) (* children_of *)
|
||||
|
||||
(** [natural_loops g dom] returns a list of loops appearing in [g],
|
||||
each loop is given as a set of vertices in the loop's body *)
|
||||
val natural_loops : graph -> (vertex -> vertex -> bool) -> (VertexISet.t * vertex * vertex) list
|
||||
|
||||
(** Floyd-Warshall returns distance and predecessor matrices.*)
|
||||
val fw : graph ->
|
||||
IntHMap.key VertexIMap.t * VertexIMap.key IntHMap.t *
|
||||
(int option) array array * (int option) array array
|
||||
|
||||
val copy : graph -> vertex -> vertex VertexMap.t * graph
|
||||
|
||||
val slice : vertex -> vertex -> graph -> vertex VertexMap.t * graph
|
||||
|
||||
(** [write_dot g t root] outputs the subgraph of [g] reachable from [root] in
|
||||
dot format with tree edges given in [t] *)
|
||||
val cfg_write_dot : graph -> (Vertex.t -> VertexISet.t) -> index -> Buffer.t -> unit
|
||||
|
||||
(** [write_dot g root] outputs the subgraph of [g] reachable from [root] in
|
||||
dot format *)
|
||||
val write_dot : graph -> index -> Buffer.t -> unit
|
||||
|
||||
(** [write_dot_partitioned fn g root] outputs the subgraph of [g] reachable
|
||||
from [root] in dot format, where vertices are partitioned into
|
||||
subgraphs according to [fn] *)
|
||||
val write_dot_partitioned :
|
||||
(index -> (string * (Format.formatter->'a)) option) ->
|
||||
graph -> index list -> Buffer.t -> unit
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Hash-consing construction based on weak hash tables *)
|
||||
|
||||
open Library
|
||||
|
||||
let verbose = ref 0
|
||||
module L = (val Log.std verbose : Log.LOG)
|
||||
|
||||
|
||||
type 'a hc = {
|
||||
desc : 'a;
|
||||
id : int;
|
||||
hash : int;
|
||||
}
|
||||
|
||||
|
||||
module Make (H : HashedType) = struct
|
||||
|
||||
include Weak.Make (struct
|
||||
type t = H.t hc
|
||||
let equal x y = H.equal x.desc y.desc
|
||||
let hash x = x.hash
|
||||
end)
|
||||
|
||||
|
||||
let id = ref 0
|
||||
|
||||
let intern t desc =
|
||||
assert( !id < max_int );
|
||||
let data = {desc; id= !id; hash= H.hash desc} in
|
||||
(* Note: If desc is already interned, this record construction is
|
||||
unnecessary. If we copied the implementation of Weak into this module,
|
||||
we could avoid constructing the record just to search for it. *)
|
||||
let data' = merge t data in
|
||||
if data == data' (* data just added *) then incr id ;
|
||||
assert( data == data' || data.id <> data'.id );
|
||||
data'
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Hash-consing construction based on weak hash tables *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
type 'a hc = private {
|
||||
desc : 'a;
|
||||
id : int;
|
||||
hash : int;
|
||||
}
|
||||
|
||||
|
||||
module Make (H : sig include HashedType val fmt: t formatter end) : sig
|
||||
|
||||
type t
|
||||
|
||||
val create : int -> t
|
||||
|
||||
val intern : t -> H.t -> H.t hc
|
||||
|
||||
val find : t -> H.t hc -> H.t hc
|
||||
|
||||
val find_all : t -> H.t hc -> H.t hc list
|
||||
|
||||
val iter : (H.t hc -> unit) -> t -> unit
|
||||
|
||||
val fold : (H.t hc -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
|
||||
val stats : t -> int * int * int * int * int * int
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,291 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Abstraction of the heap part of symbolic heaps *)
|
||||
|
||||
(* Notes:
|
||||
- The definition of Pg.of_pattern only works for patterns where only a
|
||||
single points-to predicate is needed to follow the list spine. For
|
||||
instance, the pattern for lists of even length using two points-tos in
|
||||
the body will not work.
|
||||
*)
|
||||
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
module S = Substitution
|
||||
open SymbolicHeap
|
||||
|
||||
module L = (val Log.std Config.vAbsH : Log.LOG)
|
||||
module LAbs = (val Log.std Config.vAbs : Log.LOG)
|
||||
|
||||
|
||||
(* Support ================================================================== *)
|
||||
|
||||
(* let smaller_by len q x = (SH.sizeof q) - (XSH.sizeof x) >= len *)
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Pattern Graphs
|
||||
============================================================================*)
|
||||
|
||||
module PatternGraph = struct
|
||||
include HeapGraph
|
||||
|
||||
(* the unit of meet on pattern graphs *)
|
||||
let top pat =
|
||||
singleton (Edge.map (const None) pat.Patn.params)
|
||||
|
||||
exception Meet_None
|
||||
let meet sh pat x y =
|
||||
fold_product (fun x_edg y_edg i ->
|
||||
try
|
||||
let xy_edg = Edge.meet x_edg y_edg in
|
||||
try
|
||||
let none () = raise Meet_None in
|
||||
let arg = Edge.map (Option.optionk none id) xy_edg in
|
||||
let _,body = XSH.exists_bind Vars.empty (Patn.instantiate pat arg) in
|
||||
let bex = E.map (SH.Pf.normalize sh) (SH.pure_sf body) in
|
||||
(* only add edge if pure subformula of pat simplifies to true *)
|
||||
if E.equal E.tt bex then
|
||||
add xy_edg i
|
||||
else
|
||||
i
|
||||
with Meet_None ->
|
||||
add xy_edg i
|
||||
with Undef ->
|
||||
i
|
||||
) x y empty
|
||||
|
||||
|
||||
(* let remove_path _len pat edg q = *)
|
||||
(* let ls = Edge.to_ls pat edg in *)
|
||||
(* let xs = Vars.diff (SH.fv ls) (SH.fv q) in *)
|
||||
(* (* remainder from subtract should have at least len fewer *-conjuncts *) *)
|
||||
(* (* Note: investigate dropping the proviso *) *)
|
||||
(* match Prover.subtract(* _with_proviso (smaller_by len q) *) q xs ls with *)
|
||||
(* | Prover.Success(q',_) -> Some(xs, q') *)
|
||||
(* | Prover.Failure -> None *)
|
||||
|
||||
|
||||
(** [of_pattern pat fg q] is the pattern graph corresponding to a template
|
||||
of the pattern [pat] filled in with the field graph [fg]. It is the
|
||||
meet of pattern graphs for each points-to record in [pat] *)
|
||||
let of_pattern pat sh =
|
||||
(* L.incf 6 "( Pg.of_pattern: %a" Patn.fmt pat ; *)
|
||||
(* L.decf 6 ") Pg.of_pattern: %a" fmt *)
|
||||
(* <& *)
|
||||
let {Patn.params; body} = pat
|
||||
in
|
||||
let bv = Params.fv params
|
||||
in
|
||||
let leq e f =
|
||||
(* L.printf 0 "leq %a %a = %b" E.fmt e E.fmt f <& *)
|
||||
Vars.intersect bv (E.fv f) || Vars.disjoint bv (E.fv e)
|
||||
in
|
||||
(* Note: review ignoring these existentials *)
|
||||
let _, body = XSH.exists_bind Vars.empty body
|
||||
in
|
||||
let sh' = SH.Pf.union leq sh body
|
||||
(* &> L.printf 0 "sh': %a" SH.fmt *)
|
||||
in
|
||||
let params' = Params.map (fun v -> SH.Pf.normalize body (E.mkVar v)) params
|
||||
in
|
||||
let pg = top pat
|
||||
in
|
||||
let pg =
|
||||
(* consider every edge x -o-> y in pat body *)
|
||||
SH.PtS.fold (fun {Pt.loc= x; off= o; cnt= yo} pg ->
|
||||
(* L.incf 7 "( considering pattern edge : %a" *)
|
||||
(* Pt.fmt {Pt.loc= x; off= o; cnt= yo} ; *)
|
||||
(* L.decf 7 ") pg: %a" fmt *)
|
||||
(* <& *)
|
||||
let pg' =
|
||||
(* consider every edge l -o-> e in sh *)
|
||||
SH.PtS.fold (fun {Pt.loc= l; off= o'; cnt= eo} pg ->
|
||||
if not (Off.equal o o') then pg
|
||||
else
|
||||
let edg =
|
||||
(* L.incf 7 "( considering sh edge : %a" *)
|
||||
(* Pt.fmt {Pt.loc= l; off= o'; cnt= eo} ; *)
|
||||
(* L.decf 7 ") found pattern graph edge: %a" Edge.fmt *)
|
||||
(* <& *)
|
||||
let sh' = SH.Pf.merge leq sh' x l in
|
||||
let sh' =
|
||||
match yo, eo with
|
||||
| Some(y), Some(e) -> SH.Pf.merge leq sh' y e
|
||||
| _ -> sh' in
|
||||
(* L.printf 0 "sh': %a" SH.fmt sh' ; *)
|
||||
Edge.map (fun p ->
|
||||
try
|
||||
let p' = SH.Pf.normalize sh' p in
|
||||
(* L.printf 0 "instantiating %a to %a" E.fmt p E.fmt p' ; *)
|
||||
if Vars.disjoint bv (E.fv p') then Some(p') else None
|
||||
with Not_found -> None
|
||||
) params'
|
||||
in
|
||||
add edg pg
|
||||
) sh empty
|
||||
in
|
||||
(* L.printf 8 "pg of pat edge: %a" fmt pg' ; *)
|
||||
if is_empty pg' then pg
|
||||
else
|
||||
meet sh pat pg pg'
|
||||
) body pg
|
||||
in
|
||||
(* L.printf 6 "pre-filtered pattern graph:@ %a" fmt pg; *)
|
||||
(* let pg = filter (fun edg -> None <> remove_path 1 pat edg sh) pg *)
|
||||
(* in *)
|
||||
(* add edges for existing lists of the current pattern *)
|
||||
SH.LsS.fold (fun {Ls.pat= pat'; arg} pg ->
|
||||
if not (Patn.equal pat pat') then pg
|
||||
else
|
||||
let edg = Args.map Option.some arg in
|
||||
add edg pg
|
||||
) sh pg
|
||||
|
||||
end
|
||||
|
||||
module Pg = PatternGraph
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Generalization
|
||||
============================================================================*)
|
||||
|
||||
let append_segments should_append pat (xs,sh) edg edg' =
|
||||
assert(true$>(
|
||||
if Pg.Edge.append edg edg' <> None then
|
||||
L.incf 5 "( append_segments: @[%a@ %a@]@ %a"
|
||||
Pg.Edge.fmt edg Pg.Edge.fmt edg' SH.fmt_xs (xs,sh) ));
|
||||
(fun a -> assert(true$>(
|
||||
if Pg.Edge.append edg edg' <> None then
|
||||
L.decf 5 ") append_segments:@ %a" (Option.fmt "failed" (fun ff (_,_,_,xs,sh) ->
|
||||
SH.fmt_xs ff (xs,sh))) a )))
|
||||
<&
|
||||
(* check that edges are adjacent if append should be done *)
|
||||
match Pg.Edge.append edg edg' with
|
||||
| Some(cat) when should_append edg edg' sh ->
|
||||
(* subtract a matching path from the SH *)
|
||||
(* Note: Refactor: below is almost an inlining of Pg.remove_path. *)
|
||||
let ls = Pg.Edge.to_ls pat cat in
|
||||
let ys = Vars.diff (SH.fv ls) (SH.fv sh) in
|
||||
(* Note: investigate dropping the proviso *)
|
||||
(match Prover.subtract(* _with_proviso (smaller_by 2 sh) *) sh ys ls with
|
||||
| Prover.Unknown -> None
|
||||
| Prover.Success(sh_m_cat,_) ->
|
||||
(* add a corresponding ls to the SH *)
|
||||
let xsh' = XSH.star [SH.exists_intro Vars.empty ls] sh_m_cat in
|
||||
(* Note: Can the pattern graph be incrementally updated here? *)
|
||||
let zs, sh' = XSH.exists_bind ys xsh' in
|
||||
if 2 <= !Config.vAbsH then (
|
||||
let fmt_o, _fmt_i, fmt_n = SH.fmt_did_xs ((xs,sh), (zs,sh')) in
|
||||
LAbs.printf 2 "@[<hov 2>abs_ls: creating list %a, replace:@ %t@]@ @[<hov 2>with:@ %t@]"
|
||||
SH.fmt ls fmt_o fmt_n
|
||||
);
|
||||
Some(edg, edg', cat, Vars.unions [xs; ys; zs], sh')
|
||||
)
|
||||
| _ ->
|
||||
None
|
||||
|
||||
|
||||
(** [generalize q] attempts to produce a formula [q'] logically weaker than
|
||||
[q] by appending list-segments. *)
|
||||
let generalize should_append pat (xs,sh) pgm pgs =
|
||||
assert(true$>
|
||||
L.incf 5 "( generalize:@ %a" SH.fmt_xs (xs,sh) );
|
||||
(fun (sh,(xs,_,_)) -> assert(true$>
|
||||
L.decf 5 ") generalize:@ %a" SH.fmt_xs (xs,sh)))
|
||||
<&
|
||||
(* append edges of pattern graph until no more can be *)
|
||||
let rec append_edges pg xs' sh' pgs =
|
||||
match
|
||||
Pg.take_first_pair (append_segments should_append pat (xs',sh')) pg
|
||||
with
|
||||
| Some(edg, edg', cat, xs', sh') ->
|
||||
(* update the pattern graph *)
|
||||
let pg' = Pg.add cat (Pg.remove edg (Pg.remove edg' pg)) in
|
||||
(* assert( Pg.equal pg' (Pg.of_pattern pat sh') || *)
|
||||
(* (L.warnf "incremental update of pattern graph incorrect"; true )); *)
|
||||
append_edges pg' xs' sh' true
|
||||
| None ->
|
||||
(pg, xs', sh', pgs)
|
||||
in
|
||||
(* build initial pattern graph *)
|
||||
let pg = Pg.of_pattern pat sh
|
||||
in
|
||||
(* append edges of stem *)
|
||||
let pg, xs, sh, pgs = append_edges pg xs sh pgs
|
||||
in
|
||||
let pg, xs, sh, pgs =
|
||||
if SH.DjS.is_empty sh then (pg, xs, sh, pgs)
|
||||
else
|
||||
let pg =
|
||||
(* for each disjunction... *)
|
||||
SH.DjS.fold (fun dj pg ->
|
||||
(* compute set of all edges in any disjunct *)
|
||||
let dt_edges =
|
||||
Dj.fold (fun dt edgs ->
|
||||
let pg_dt =
|
||||
try IntMap.find (SH.lbl dt) pgm with Not_found -> Pg.empty in
|
||||
Pg.union pg_dt edgs
|
||||
) dj Pg.empty in
|
||||
(* add edges common to all disjuncts *)
|
||||
let pg_dj =
|
||||
Dj.fold (fun dt pg_dj ->
|
||||
let pg_dt =
|
||||
try IntMap.find (SH.lbl dt) pgm with Not_found -> Pg.empty in
|
||||
(* add 0-length edges of dt_edges based on dt's equalities *)
|
||||
let pg_dt =
|
||||
Pg.fold (fun edg pg_dt ->
|
||||
if
|
||||
HeapGraph.Edge.fold_links (fun link so_far -> so_far &&
|
||||
match link with
|
||||
| (Some(a), Some(d)) ->
|
||||
E.equal (SH.Pf.normalize dt a) (SH.Pf.normalize dt d)
|
||||
| _ -> false
|
||||
) edg true
|
||||
then
|
||||
Pg.add edg pg_dt
|
||||
else
|
||||
pg_dt
|
||||
) dt_edges pg_dt in
|
||||
Pg.meet dt pat pg_dt pg_dj
|
||||
) dj (Pg.top pat) in
|
||||
Pg.union pg_dj pg
|
||||
) sh pg
|
||||
in
|
||||
(* append edges of stem plus added edges from disjunctions *)
|
||||
append_edges pg xs sh pgs
|
||||
in
|
||||
(* save updated and transitively closed pattern graph *)
|
||||
let pgm = IntMap.add (SH.lbl sh) (Pg.transitive_closure pg) pgm in
|
||||
(sh, (xs, pgm, pgs))
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Entry Point
|
||||
============================================================================*)
|
||||
|
||||
(** [abstract q] attemps to apply predicate-based generalization and
|
||||
disjunction factorization to [q], returning [Some q'] if such a [q'] was
|
||||
obtained, and [None] otherwise. *)
|
||||
let abstract (xs,sh) =
|
||||
let should_append = Reachability.should_append (xs,sh) in
|
||||
let pgm = IntMap.empty in
|
||||
let sh',(xs',_,pgs) =
|
||||
(* try each pattern *)
|
||||
Discovery.fold (fun pat (sh,(xs,pgm,pgs)) ->
|
||||
let sh, (xs, pgm, pgs) =
|
||||
SH.map_fold_distrib (fun dt (xs, pgm, pgs) ->
|
||||
generalize should_append pat (xs,dt) pgm pgs
|
||||
) sh (xs,pgm,pgs) in
|
||||
let xs, sh = SH.normalize (xs,sh) in
|
||||
(sh, (xs, pgm, pgs))
|
||||
) (SH.exists_intro xs sh) (sh,(xs,pgm,false))
|
||||
in
|
||||
if pgs then Some(xs',sh') else None
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Abstraction of spatial part of symbolic heaps *)
|
||||
|
||||
open Variable
|
||||
open SymbolicHeap
|
||||
|
||||
|
||||
(*============================================================================
|
||||
HeapAbstraction
|
||||
============================================================================*)
|
||||
|
||||
val abstract : Vars.t * SH.t -> (Vars.t * SH.t) option
|
||||
|
|
@ -0,0 +1,143 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Graph representation of pointer structure of symbolic heaps *)
|
||||
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
module S = Substitution
|
||||
open SymbolicHeap
|
||||
|
||||
module L = (val Log.std Config.vHG : Log.LOG)
|
||||
|
||||
|
||||
(* Timing =================================================================== *)
|
||||
|
||||
let add_with_closure_tmr = Timer.create "HeapGraph.add_with_closure"
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Heap Graphs
|
||||
============================================================================*)
|
||||
|
||||
|
||||
(** "Lifted" value expressions. *)
|
||||
module LE = struct
|
||||
|
||||
type t = E.t option
|
||||
|
||||
let fv eo = Option.option Vars.empty E.fv eo
|
||||
let map_exps s eo = Option.map s eo
|
||||
let fold_exps fn eo z = Option.option z (fun e -> E.fold fn e z) eo
|
||||
let equal = Option.equal E.equal
|
||||
let compare = Option.compare E.compare
|
||||
let fmtp fxt ff eo = Option.fmt "-" (E.fmtp fxt) ff eo
|
||||
let fmt ff eo = fmtp (Vars.empty,Vars.empty) ff eo
|
||||
let fmt_caml ff eo =
|
||||
Option.fmt "None" (fun ff -> Format.fprintf ff "Some(%a)" E.fmt_caml) ff eo
|
||||
|
||||
end
|
||||
|
||||
|
||||
module Edge = struct
|
||||
|
||||
include BiEdge.Make (LE)
|
||||
|
||||
let fmt ff e = Format.fprintf ff "@[(%a)@]" fmt e
|
||||
|
||||
|
||||
let meet x y =
|
||||
(* greatest lower bound in the lattice where Undef < Some < None *)
|
||||
let meet_ lx ly =
|
||||
match lx, ly with
|
||||
| None , None -> None
|
||||
| None , Some _ -> ly
|
||||
| Some _, None -> lx
|
||||
| Some _, Some _ when LE.equal lx ly -> lx
|
||||
| Some _, Some _ -> raise Undef
|
||||
in
|
||||
try map2 meet_ x y
|
||||
with Invalid_argument _ -> raise Undef
|
||||
|
||||
|
||||
let drop none x = map (Option.optionk none id) x
|
||||
|
||||
|
||||
let append_unchecked = append
|
||||
|
||||
let append edg edg' =
|
||||
let are_adjacent =
|
||||
try
|
||||
(* only the common meeting point must be present *)
|
||||
let btwn = drop (fun () -> raise Undef) (Args.between edg edg') in
|
||||
Args.fold_links (fun (a,d) so_far -> so_far && E.equal a d) btwn true
|
||||
with Undef -> false
|
||||
in
|
||||
if are_adjacent
|
||||
then Some (append edg edg')
|
||||
else None
|
||||
|
||||
let to_ls pat edg =
|
||||
(* L.incf 0 "( to_ls: %a %a" Patn.fmt pat fmt edg ; *)
|
||||
(* L.decf 0 ") to_ls: %a" SH.fmt <& *)
|
||||
let none () = E.mkVar (Var.gensym "drop" Var.PointerSort) in
|
||||
let ls = {Ls.
|
||||
pat= pat;
|
||||
len= E.mkVar (Var.gensym "len" Var.IntegerSort);
|
||||
arg= drop none edg
|
||||
} in
|
||||
SH.LsS.star [ls] SH.emp
|
||||
|
||||
let fmt ff edg = Format.fprintf ff "@[(%a)@]" fmt edg
|
||||
|
||||
end
|
||||
|
||||
|
||||
module EdgeSet = Set.Make(Edge)
|
||||
|
||||
|
||||
let fmt ff pg =
|
||||
Format.fprintf ff "@[<hov 1>[%a]@]"
|
||||
(List.fmt ";@ " Edge.fmt) (EdgeSet.to_list pg)
|
||||
|
||||
|
||||
let add_with_closure edg g =
|
||||
Timer.start add_with_closure_tmr ;
|
||||
(fun _ -> Timer.stop add_with_closure_tmr)
|
||||
<&
|
||||
let hds =
|
||||
EdgeSet.fold (fun g_edg h ->
|
||||
match Edge.append g_edg edg with
|
||||
| None -> h
|
||||
| Some(g_edg_edg) -> EdgeSet.add g_edg_edg h
|
||||
) g EdgeSet.empty
|
||||
in
|
||||
let tls =
|
||||
EdgeSet.fold (fun g_edg h ->
|
||||
match Edge.append edg g_edg with
|
||||
| None -> h
|
||||
| Some(edg_g_edg) -> EdgeSet.add edg_g_edg h
|
||||
) g EdgeSet.empty
|
||||
in
|
||||
let spn =
|
||||
EdgeSet.fold_product (fun hd_edg tl_edg h ->
|
||||
(* Note: It shouldn't be necessary to call append_unchecked here,
|
||||
something is wrong with Args.adjacent and normalization. *)
|
||||
EdgeSet.add (Edge.append_unchecked hd_edg tl_edg) h
|
||||
) hds tls EdgeSet.empty
|
||||
in
|
||||
EdgeSet.union spn (EdgeSet.union tls (EdgeSet.union hds (EdgeSet.add edg g)))
|
||||
|
||||
|
||||
(** [union_with_closure g g'] is the transitive closure of [g] union [g'],
|
||||
assuming [g'] is closed. *)
|
||||
let union_with_closure g g' = EdgeSet.fold add_with_closure g g'
|
||||
|
||||
|
||||
let transitive_closure g = union_with_closure g EdgeSet.empty
|
||||
|
||||
|
||||
include EdgeSet
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Graph representation of heap structure of symbolic heaps *)
|
||||
|
||||
open Library
|
||||
|
||||
open Expression
|
||||
open SYMBOLIC_HEAP
|
||||
open SymbolicHeap
|
||||
|
||||
|
||||
module Edge : sig
|
||||
include BIEDGE
|
||||
with type a = Exp.t option
|
||||
|
||||
val meet : t -> t -> t
|
||||
|
||||
val append : t -> t -> t option
|
||||
|
||||
val to_ls : Patn.t -> t -> SH.t
|
||||
end
|
||||
|
||||
|
||||
include Set.S with type elt = Edge.t
|
||||
|
||||
val fmt : t formatter
|
||||
|
||||
val add_with_closure : Edge.t -> t -> t
|
||||
|
||||
val union_with_closure : t -> t -> t
|
||||
|
||||
val transitive_closure : t -> t
|
||||
|
||||
|
||||
val add_with_closure_tmr : Timer.t
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Hooks for very applicaton-specific behavior. *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
let var_name name =
|
||||
if !Config.vVar > 2 then
|
||||
name
|
||||
else
|
||||
match name with
|
||||
| "arg_tmp" -> "at"
|
||||
| "cast_tmp" -> "ct"
|
||||
| "incr_load_tmp" -> "ilt"
|
||||
| "load_tmp" -> "lt"
|
||||
| "lval_cast_tmp" -> "lct"
|
||||
| "lval_kill_tmp" -> "lct"
|
||||
| "store_cast_tmp" -> "sct"
|
||||
| _ when !Config.vVar > 1 ->
|
||||
name
|
||||
| "_WDF_DEVICE_EXTENSION_TYPE_INFO" -> "DETI"
|
||||
| _ ->
|
||||
String.filteri (fun i c -> i = 0 || c <> Char.lowercase c) name
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Hooks for very applicaton-specific behavior. *)
|
||||
|
||||
|
||||
val var_name : string -> string
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Initialization *)
|
||||
|
||||
open Library
|
||||
|
||||
|
||||
let thunks = ref []
|
||||
|
||||
let register thunk =
|
||||
thunks := thunk :: !thunks
|
||||
|
||||
let initialize program =
|
||||
List.iter (fun thunk -> thunk program) !thunks
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open Program
|
||||
|
||||
|
||||
val register : (Prog.t -> unit) -> unit
|
||||
|
||||
val initialize : Prog.t -> unit
|
||||
|
|
@ -0,0 +1,275 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Inline function calls. *)
|
||||
|
||||
open Library
|
||||
|
||||
(**/**)
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
module S = Substitution
|
||||
open Program
|
||||
module I = Inst
|
||||
module C = Cmnd
|
||||
module K = ControlPoint
|
||||
(**/**)
|
||||
|
||||
module L = (val Log.std Config.vInline : Log.LOG)
|
||||
|
||||
|
||||
(** Discover which procs are inline-able. *)
|
||||
|
||||
|
||||
module CallGraph = Graph.Make (Proc.Id) (Proc.Id) (K.Id)
|
||||
|
||||
let calculate_call_map program =
|
||||
Prog.fold_procs (fun caller call_map ->
|
||||
CFG.fold_edges (fun _ cm -> cm) (fun (u,c,_v) call_map ->
|
||||
match c with
|
||||
| C.Call{Call.targets}
|
||||
| C.ICall{Call.targets} -> List.fold (fun x a -> (caller.Proc.id, x, K.id u) :: a) targets call_map
|
||||
| _ -> call_map
|
||||
) caller.Proc.cfg (K.id caller.Proc.entry) call_map
|
||||
) program []
|
||||
|
||||
let graph_of_call_map call_map =
|
||||
let g = CallGraph.create () in
|
||||
List.iter (fun (caller,callee,node_id) ->
|
||||
let u = CallGraph.add_vertex g (caller,caller) in
|
||||
let v = CallGraph.add_vertex g (callee,callee) in
|
||||
CallGraph.add_edge g u (node_id) v
|
||||
) call_map ;
|
||||
g
|
||||
|
||||
let calculate_rec_procs program =
|
||||
let m = calculate_call_map program in
|
||||
let g = graph_of_call_map m in
|
||||
let main = program.Prog.main in
|
||||
let main_vtx = CallGraph.add_vertex g (main,main) in
|
||||
CallGraph.root_vertex g main_vtx ;
|
||||
CallGraph.remove_unreachable g ;
|
||||
let cs = CallGraph.cutpoints main_vtx in
|
||||
L.printf 2 "cutpoints %a" (List.fmt "," CallGraph.Vertex.fmt) (CallGraph.VertexSet.to_list cs) ;
|
||||
let recs =
|
||||
CallGraph.VertexSet.fold (fun c cs ->
|
||||
(CallGraph.index_of c) :: cs
|
||||
) cs [] in
|
||||
let uses = Proc.IdHMap.create 20 in
|
||||
let main_idx = CallGraph.index_of main_vtx in
|
||||
CallGraph.iter_edges
|
||||
(fun c -> Proc.IdHMap.add uses (CallGraph.index_of c) (List.length (CallGraph.predecessors c)))
|
||||
(fun _edge -> ())
|
||||
g main_idx ;
|
||||
Proc.IdHMap.add uses main_idx 1 ;
|
||||
(recs, uses)
|
||||
|
||||
let recursive recs p =
|
||||
List.mem p.Proc.id recs
|
||||
|
||||
(* Returns true, if procedure is a leaf, (makes no calls) *)
|
||||
let contains_loop_and_leaf_proc proc =
|
||||
let leaf_proc = ref true in
|
||||
let contains_loop = ref false in
|
||||
CFG.iter_edges
|
||||
(fun v ->
|
||||
match K.sort v with
|
||||
| Some(K.Cut) -> contains_loop := true
|
||||
| _ -> ())
|
||||
(fun (_v,c,_v') ->
|
||||
match c with
|
||||
| C.Call(_)
|
||||
| C.ICall _ -> leaf_proc := false
|
||||
| _ -> ()
|
||||
)
|
||||
proc.Proc.cfg (K.id proc.Proc.entry) ;
|
||||
(!contains_loop, !leaf_proc)
|
||||
|
||||
|
||||
let inlineable (recs,uses) p in_loop =
|
||||
let contains_loops,leaf_proc = contains_loop_and_leaf_proc p in
|
||||
let macro = leaf_proc && (not contains_loops) in
|
||||
let no_rec = not (recursive recs p) in
|
||||
let thin_wrapper = no_rec && (not contains_loops) in
|
||||
let single_call_not_in_loop = no_rec && (not in_loop) && (Proc.IdHMap.find uses (p.Proc.id) = 1) in
|
||||
L.printf 2 "proc %a: macro:%b, thin_wrapper:%b, single_call_not_in_loop: %b no_rec:%b"
|
||||
Proc.Id.fmt p.Proc.id macro thin_wrapper single_call_not_in_loop no_rec ;
|
||||
match Config.optimize_inline with
|
||||
| 0 -> false
|
||||
| 1 -> macro
|
||||
| 2 -> macro || thin_wrapper
|
||||
| 3 -> macro || thin_wrapper || single_call_not_in_loop
|
||||
| 4 -> no_rec
|
||||
| _ -> failwith "Unknown inline level"
|
||||
|
||||
|
||||
(** inline_proc and inline_body *)
|
||||
|
||||
(* Clone callee graph. *)
|
||||
let clone_for_inlining caller callee =
|
||||
|
||||
(* Map of callee vertex to corresponding vertex in inlined caller code. *)
|
||||
let module CPHMap = HashMap.Make(K) in
|
||||
let proc_to_inline = CPHMap.create 32 in
|
||||
|
||||
let {Proc.id= caller_id; cfg= caller_cfg} = caller in
|
||||
let {Proc.cfg= callee_cfg; entry= callee_entry; exit= callee_exit} = callee in
|
||||
|
||||
(* Clone callee vertices and edges into caller. *)
|
||||
CFG.iter_vertices (fun v ->
|
||||
let v' = CFG.add_vertex caller_cfg (K.mk_label ?sort:(K.sort v) (K.pos v) caller_id) in
|
||||
CPHMap.add proc_to_inline v v'
|
||||
) callee_cfg ;
|
||||
CFG.iter_edges (fun _ -> ()) (fun (u,c,v) ->
|
||||
let u' = CPHMap.find proc_to_inline u in
|
||||
let v' = CPHMap.find proc_to_inline v in
|
||||
CFG.add_edge caller_cfg u' c v'
|
||||
) callee_cfg (K.id callee_entry) ;
|
||||
|
||||
(* Find cloned entry and exit. *)
|
||||
let inlined_entry = CPHMap.find proc_to_inline callee_entry in
|
||||
let inlined_exit = CPHMap.find proc_to_inline callee_exit in
|
||||
|
||||
(* Return cloned callee_cfg as caller sub-graph. *)
|
||||
(inlined_entry, inlined_exit)
|
||||
|
||||
|
||||
(*
|
||||
Translate this edge in [proc]:
|
||||
|
||||
u --Call(p,args)--> v
|
||||
|
||||
into this edge in [proc] (with p's locals and formals now added to [proc]'s):
|
||||
|
||||
u --Inst[frmls=actls]--> clone_for_inlining(p) --Inst[Kill(frmls,locals)] --> v
|
||||
|
||||
The clone_for_inlining function clones the body of p.
|
||||
*)
|
||||
|
||||
let work_count = ref 0
|
||||
|
||||
let proc procs recs_uses ({Proc.id; locals; cfg; entry} as proc) =
|
||||
L.incf 1 "( analyzing %a" Proc.Id.fmt id ; (fun _p -> L.decf 1 ")") <&
|
||||
|
||||
let in_loop =
|
||||
if Config.optimize_inline = 3 then (
|
||||
L.incf 3 "( calculating SCC" ; (fun _ -> L.decf 3 ")") <&
|
||||
let vtx_to_scc = CFG.scc cfg in
|
||||
fun v ->
|
||||
(List.length (CFG.VertexMap.find v vtx_to_scc)) > 1
|
||||
)
|
||||
else
|
||||
fun _ -> false in
|
||||
|
||||
(* Replacing the graph while folding over it is bad. So we first collect eligible call-sites. *)
|
||||
let inline_candidates =
|
||||
CFG.fold_edges (fun _ acc -> acc)
|
||||
(fun (u,c,v) acc ->
|
||||
match c with
|
||||
| C.Call{Call.proc; actuals; areturn} ->
|
||||
let callee =
|
||||
try Proc.IdHMap.find procs proc
|
||||
with Not_found -> failwithf "Undefined procedure: %a" Proc.Id.fmt proc in
|
||||
if inlineable recs_uses callee (in_loop u) then (
|
||||
L.printf 1 "inlining %a" Proc.Id.fmt proc ;
|
||||
(u, c, v, Call.mk callee actuals areturn) :: acc
|
||||
)
|
||||
else (
|
||||
L.printf 2 "Not inlining %a" Proc.Id.fmt proc ;
|
||||
acc
|
||||
)
|
||||
(* Don't care about non-Call commands *)
|
||||
| _ ->
|
||||
acc
|
||||
) cfg (K.id entry) [] in
|
||||
|
||||
(* Inline an inline-candidate. Add it's (formals+locals) and ret-sites to [acc]. *)
|
||||
let inline (call_site, c, retn_site, call) caller_locals =
|
||||
let {Call.proc= callee; areturn} = call in
|
||||
let {Proc.formals; freturn; locals} = callee in
|
||||
incr work_count ;
|
||||
|
||||
(* Move actuals to formals. *)
|
||||
let prologue =
|
||||
let frmls_to_actls,_ = Call.args {call with Call.areturn= None} in
|
||||
S.fold (fun f a blk ->
|
||||
match E.desc f with
|
||||
| E.Var(f) -> I.mk (I.Move(f, a)) (K.pos call_site) :: blk
|
||||
| _ -> assert false
|
||||
) frmls_to_actls [] in
|
||||
|
||||
(* Clone body of callee. *)
|
||||
let inlined_entry, inlined_exit =
|
||||
clone_for_inlining proc callee in
|
||||
|
||||
(* Move formal return to actual return. *)
|
||||
let epilogue =
|
||||
match freturn, areturn with
|
||||
| Some(frtrn), Some(artrn) -> [I.mk (I.Move(artrn, E.mkVar frtrn)) (K.pos inlined_exit)]
|
||||
| _ -> [] in
|
||||
|
||||
(* Kill callee formals, formal return, and locals *)
|
||||
let extra_locals =
|
||||
Vars.union (Vars.of_list formals) (Option.fold Vars.add freturn locals) in
|
||||
let epilogue =
|
||||
epilogue @ [I.mk I.(Kill(extra_locals)) (K.pos inlined_exit)] in
|
||||
|
||||
(* Connect call_site -prologue-> entry and exit -epilogue-> retn_site *)
|
||||
CFG.add_block_edge cfg call_site prologue inlined_entry ;
|
||||
CFG.add_block_edge cfg inlined_exit epilogue retn_site ;
|
||||
CFG.remove_edge cfg call_site c retn_site ;
|
||||
|
||||
(Vars.union extra_locals caller_locals)
|
||||
in
|
||||
|
||||
(* Inline calls. *)
|
||||
let locals = List.fold inline inline_candidates locals in
|
||||
|
||||
{proc with Proc.locals}
|
||||
|
||||
|
||||
(* Entry point *)
|
||||
let prog program =
|
||||
L.incf 1 "( inline" ; (fun _p -> L.decf 1 ")") <&
|
||||
if Config.optimize_inline <= 0 then program
|
||||
else
|
||||
|
||||
let rec loop p =
|
||||
work_count := 0 ;
|
||||
let recs, uses = calculate_rec_procs p in
|
||||
(* Notes: Recalculate addr_taken, based on call graph *)
|
||||
|
||||
(* Remove all the procedures not used from call graph *)
|
||||
let procs = p.Prog.procs in
|
||||
Proc.IdHMap.filter (fun pid _ ->
|
||||
let b = (* Don't remove procedures that are used *)
|
||||
try Proc.IdHMap.find uses pid > 0
|
||||
with Not_found -> false in
|
||||
if not b then (
|
||||
L.printf 2 "remove unused proc %a" Proc.Id.fmt pid ;
|
||||
incr work_count
|
||||
);
|
||||
b
|
||||
) procs ;
|
||||
if !work_count > 0 then (
|
||||
L.printf 1 "removed %d unused procs" !work_count ;
|
||||
work_count := 0
|
||||
);
|
||||
|
||||
let p' = Prog.map_procs (proc procs (recs, uses)) p in
|
||||
if !work_count > 0 then (
|
||||
L.printf 1 "inlined %d procs" !work_count ;
|
||||
loop p'
|
||||
)
|
||||
else
|
||||
p'
|
||||
in
|
||||
let program = loop program
|
||||
in
|
||||
let ({Prog.procs; global_setup; inits; addr_taken} as program) = program
|
||||
in
|
||||
let global_setup = List.filter (Proc.IdHMap.mem procs) global_setup
|
||||
and inits = List.filter (Proc.IdHMap.mem procs) inits
|
||||
and addr_taken = List.filter (Proc.IdHMap.mem procs) addr_taken
|
||||
in
|
||||
{program with Prog.global_setup; inits; addr_taken}
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Optimize program by inlining function calls *)
|
||||
|
||||
open Program
|
||||
|
||||
|
||||
(** Inline Cals, starting from [p.main]. *)
|
||||
val prog : Prog.t -> Prog.t
|
||||
|
|
@ -0,0 +1,451 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Generation of instrumented arithmetic programs from analysis results *)
|
||||
|
||||
(**/**)
|
||||
open Library
|
||||
|
||||
module HC = HashCons
|
||||
open Type
|
||||
open Variable
|
||||
open Expression
|
||||
module E = Exp
|
||||
module S = Substitution
|
||||
open SymbolicHeap
|
||||
open Program
|
||||
module I = Inst
|
||||
module K = ControlPoint
|
||||
(**/**)
|
||||
|
||||
module L = (val Log.std Config.vInstr : Log.LOG)
|
||||
|
||||
|
||||
let fmt_xs = Vars.fmt_embrace "@[<hov 2>? " " .@]@ "
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Convert SLAyer Expressions, Formulas, Commands to T2 syntax
|
||||
============================================================================*)
|
||||
|
||||
let emit_pos buf {Position.dir; file; line} =
|
||||
Printf.bprintf buf "AT(%i,\"%s\")\t" line (Filename.concat dir file)
|
||||
|
||||
(* Note: Should not use Var.fmt or else it should check for verbosity *)
|
||||
(* The problem is we print bad variable names (for T2) if verbose is set *)
|
||||
let emit_var buf v = Printf.bprintf buf "%s" (Format.asprintf "%a" Var.fmt v)
|
||||
|
||||
(* Note: " *)
|
||||
let emit_fld buf f = Printf.bprintf buf "%s" (Format.asprintf "%a" Fld.fmt f)
|
||||
|
||||
let isternary e =
|
||||
match E.desc e with
|
||||
| E.Op3(E.Ite,_,E.Num(1L),E.Num(0L)) -> true
|
||||
| _ -> false
|
||||
|
||||
let rec emit_exp buf e =
|
||||
emit_exp_ buf (E.desc e)
|
||||
|
||||
and emit_exp_ buf e =
|
||||
|
||||
match e with
|
||||
|
||||
(* (0 != (g ? 1 : 0)) is just g *)
|
||||
| E.Op1(E.Not,E.Eq({HC.desc=E.Num(0L)},e2)) when isternary(e2) ->
|
||||
(match E.desc e2 with
|
||||
| E.Op3(E.Ite,g,_,_) ->
|
||||
L.printf 3 "[0] Saving ternary expression";
|
||||
emit_exp_ buf g
|
||||
| _ -> failwith "emit_exp: ternary fail") (* should be impossible to reach *)
|
||||
(* ((g ? 1 : 0) = v) can be rewritten into g && v == 1 || !g && v == 0 *)
|
||||
| E.Eq(e1,e2) when isternary(e1) || isternary(e2) ->
|
||||
(match E.desc e1, E.desc e2 with
|
||||
| E.Op3(E.Ite,g1,_,_), E.Op3(E.Ite,g2,_,_) ->
|
||||
L.printf 3 "Saving ternary expression %a" E.fmt e1;
|
||||
emit_exp buf (E.mkOr [|E.mkAnd[|E.name g1; E.name g2|];
|
||||
E.mkAnd[|E.mkNot (E.name g1); E.mkNot (E.name g2)|]|])
|
||||
| E.Op3(E.Ite,g,_,_), E.Var(_) ->
|
||||
L.printf 3 "Saving ternary expression %a" E.fmt e2;
|
||||
emit_exp buf (E.mkOr [|E.mkAnd[|E.name g; E.mkEq e2 E.one |];
|
||||
E.mkAnd[|E.mkNot (E.name g); E.mkEq e2 E.zero|]|])
|
||||
| E.Var(_), E.Op3(E.Ite,g,_,_) ->
|
||||
L.printf 3 "Saving ternary expression (%a = %a)" E.fmt e1 E.fmt e2;
|
||||
emit_exp buf (E.mkOr [|E.mkAnd[|E.name g; E.mkEq e1 E.one |];
|
||||
E.mkAnd[|E.mkNot (E.name g); E.mkEq e1 E.zero|]|])
|
||||
| E.Op3(E.Ite,_,_,_), e ->
|
||||
L.printf 3 "[0] Instrumentation: Dropped %a" E.fmt e1;
|
||||
Printf.bprintf buf "(nondet() == %a)" emit_exp_ e
|
||||
| e, E.Op3(E.Ite,_,_,_) ->
|
||||
L.printf 3 "[0] Instrumentation: Dropped %a" E.fmt e2;
|
||||
Printf.bprintf buf "(%a == nondet())" emit_exp_ e
|
||||
| _, _ ->
|
||||
failwith "emit_exp: ternary fail") (* should be impossible to reach *)
|
||||
|
||||
| E.Var(v) -> emit_var buf v
|
||||
| E.Nil -> Printf.bprintf buf "0"
|
||||
| E.App(f,a) ->
|
||||
(match E.desc f with
|
||||
| E.Add(f) -> Printf.bprintf buf "(%a + %a)" emit_exp a emit_fld f
|
||||
| E.Sub(f) -> Printf.bprintf buf "(%a - %a)" emit_exp a emit_fld f
|
||||
| _ -> failwith "emit_exp: unexpected function"
|
||||
)
|
||||
| E.Add(_) | E.Sub(_) | E.Idx -> failwith "emit_exp: unexpected offset"
|
||||
| E.Bas(_) -> Printf.bprintf buf "0"
|
||||
| E.Eq(e,f) -> Printf.bprintf buf "(%a == %a)" emit_exp e emit_exp f
|
||||
| E.Num(i) -> Printf.bprintf buf "%Li" i
|
||||
| E.Str(s) -> Printf.bprintf buf "\"%s\"" s
|
||||
| E.Op1(E.Not,b) -> Printf.bprintf buf "(! %a)" emit_exp_ b
|
||||
| E.Op1(E.ZMin,v) -> Printf.bprintf buf "(- %a)" emit_exp_ v
|
||||
| E.Op2(E.ZLt,e,f) -> Printf.bprintf buf "(%a < %a)" emit_exp_ e emit_exp_ f
|
||||
| E.Op2(E.ZLe,e,f) -> Printf.bprintf buf "(%a <= %a)" emit_exp_ e emit_exp_ f
|
||||
| E.Op2(E.ZGt,e,f) -> Printf.bprintf buf "(%a > %a)" emit_exp_ e emit_exp_ f
|
||||
| E.Op2(E.ZGe,e,f) -> Printf.bprintf buf "(%a >= %a)" emit_exp_ e emit_exp_ f
|
||||
| E.Op2(E.ZDiv,e,f) -> Printf.bprintf buf "(%a / %a)" emit_exp_ e emit_exp_ f
|
||||
| E.Op2(E.ZRem,e,f) -> Printf.bprintf buf "(%a %% %a)" emit_exp_ e emit_exp_ f
|
||||
| E.Op3(E.Ite,g,t,e) when E.is_boolean (E.name t) ->
|
||||
emit_exp buf (E.mkOr [|E.mkAnd[|E.name g; E.name t|];
|
||||
E.mkAnd[|E.mkNot (E.name g); E.name e|]|])
|
||||
| E.OpN(E.Distinct,es) ->
|
||||
(match Array.to_list es with
|
||||
| [_] -> emit_exp buf E.tt
|
||||
| _ ->
|
||||
emit_exp buf
|
||||
(E.mkAnd
|
||||
(Array.of_list
|
||||
(List.fold_pairs (fun e f dqs ->
|
||||
E.mkDq (E.name e) (E.name f) :: dqs
|
||||
) (Array.to_list es) []))))
|
||||
| E.OpN(E.And,bs) -> emit_expl " && " "(0<1)" buf
|
||||
(List.filter
|
||||
(fun b ->
|
||||
match b with
|
||||
| E.Var(v) when Var.sort v == Var.BooleanSort ->
|
||||
let _ = L.printf 3 "Dropping singleton bool var %a" Var.fmt v in
|
||||
false
|
||||
| E.Op1(E.Allocd,_) as e ->
|
||||
let _ = L.printf 3 "Dropping singleton allocd() %a" E.fmt (E.name e) in
|
||||
false
|
||||
| _ -> true) (Array.to_list bs))
|
||||
| E.OpN(E.Or,bs) -> emit_expl " || " "(0<0)" buf (Array.to_list bs)
|
||||
| E.OpN(E.ZAdd,es) -> emit_expl " + " "0" buf (Array.to_list es)
|
||||
| E.OpN(E.ZMul,es) -> emit_expl " * " "1" buf (Array.to_list es)
|
||||
|
||||
| E.Op1(E.Allocd,_)
|
||||
| E.Op2(E.ZMod,_,_)
|
||||
| E.Op3(E.Ite,_,_,_)
|
||||
| E.OpN(E.UFun _,_) ->
|
||||
L.printf 3 "Instrumentation: Dropped %a" E.fmt (E.name e) ;
|
||||
Printf.bprintf buf "nondet()"
|
||||
|
||||
|
||||
and emit_expl sep unit buf = function
|
||||
| [] ->
|
||||
Printf.bprintf buf "%s" unit
|
||||
| [e] ->
|
||||
emit_exp_ buf e
|
||||
| e::el ->
|
||||
Printf.bprintf buf "(%a%a)"
|
||||
emit_exp_ e
|
||||
(fun buf el ->
|
||||
List.iter (fun e ->
|
||||
Printf.bprintf buf "%s%a" sep emit_exp_ e
|
||||
) el
|
||||
) el
|
||||
|
||||
|
||||
let emit_kill buf pos xs =
|
||||
if Vars.is_empty xs then () else
|
||||
Printf.bprintf buf "%a%a\n"
|
||||
emit_pos pos
|
||||
(fun buf ->
|
||||
Vars.iter (fun v -> Printf.bprintf buf "%a := nondet(); " emit_var v)
|
||||
) xs
|
||||
|
||||
|
||||
let emit_move buf pos v e =
|
||||
match E.desc e with
|
||||
| E.Var(u) when Var.equal v u -> ()
|
||||
| _ -> Printf.bprintf buf "%a%a := %a;\n" emit_pos pos emit_var v emit_exp e
|
||||
|
||||
|
||||
let emit_assume buf pos bexp =
|
||||
if E.equal E.tt bexp then () else
|
||||
Printf.bprintf buf "%aassume(%a);\n" emit_pos pos emit_exp bexp
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Core instrumentation approximation and logic
|
||||
============================================================================*)
|
||||
|
||||
module KH = HashMap.Make(K.Id)
|
||||
|
||||
let enclosing_proc = KH.create 128
|
||||
|
||||
|
||||
module ExpMSet = MultiSet.Make(Exp)
|
||||
|
||||
(** [approximate us xsh] is a quantified boolean expression [(xs,b)] no
|
||||
stronger than [xsh] that can be usefully translated to T2. *)
|
||||
let approximate us xsh =
|
||||
assert(true$>
|
||||
L.incf 2 "( approximate:@ %a" XSH.fmt xsh);
|
||||
(fun (xs,b) -> assert(true$>
|
||||
L.decf 2 ") approximate:@ %a%a" fmt_xs xs E.fmt b))
|
||||
<&
|
||||
(*
|
||||
let rec aux locs q z =
|
||||
(* take boolean part of q *)
|
||||
let bex = SH.Pf.term q
|
||||
in
|
||||
let q = SH.Pf.empty q
|
||||
in
|
||||
(* convert lists to disjunctions based on 0,1,many length, convert to DNF,
|
||||
for each branch assert the allocated locs on that branch are
|
||||
distinct *)
|
||||
let locs = SH.PtS.fold (fun {Pt.loc} z -> ExpMSet.add loc z) q locs in
|
||||
let q = SH.PtS.empty q
|
||||
in
|
||||
match SH.LsS.trychoose q with
|
||||
| Some({Ls.len; arg={Args.fore; back}} as ls) ->
|
||||
let q = SH.LsS.remove ls q in
|
||||
let q_ls_emp = SH.Pf.star (Ls.empty_eqs ls) q in
|
||||
let q_ls_nemp = SH.Pf.star [E.mkGt len E.zero] q
|
||||
in
|
||||
let ls_empty = aux locs q_ls_emp []
|
||||
in
|
||||
let link_allocd link z =
|
||||
if link = [] then z else
|
||||
let locs =
|
||||
List.fold (fun (a,_,_) z -> ExpMSet.add a z) link locs in
|
||||
aux locs q_ls_nemp z
|
||||
in
|
||||
bex
|
||||
:: E.mkGe len E.zero (* logically redundant *)
|
||||
:: E.mkOr[ E.mkAnd ls_empty ;
|
||||
E.mkAnd (link_allocd fore (link_allocd back [])) ]
|
||||
:: z
|
||||
| None ->
|
||||
match SH.DjS.trychoose q with
|
||||
| Some(dj) ->
|
||||
let q = SH.DjS.remove dj q in
|
||||
let dj_conseqs =
|
||||
Dj.fold (fun dt bs -> E.mkAnd (aux locs (SH.star [dt] q) []) :: bs)
|
||||
dj []
|
||||
in
|
||||
bex :: E.mkOr dj_conseqs :: z
|
||||
| None ->
|
||||
let mk_distinct_dqs es z =
|
||||
ExpMSet.fold_pairs (fun e f dqs ->
|
||||
E.mkDq e f :: dqs
|
||||
) es z
|
||||
in
|
||||
bex :: mk_distinct_dqs (ExpMSet.add E.nil locs) z
|
||||
in
|
||||
*)
|
||||
let xs, sh = XSH.exists_bind us xsh in
|
||||
let mk_distinct_dqs es z =
|
||||
ExpMSet.fold_pairs (fun e f dqs ->
|
||||
E.mkDq e f :: dqs
|
||||
) es z
|
||||
in
|
||||
(* only surface-level points-to *)
|
||||
let locs = SH.PtS.fold (fun {Pt.loc} z -> ExpMSet.add loc z) sh ExpMSet.empty in
|
||||
let _ = ExpMSet.iter (fun l -> L.printf 3 "locs: %a" E.fmt l) locs in
|
||||
let z = mk_distinct_dqs (ExpMSet.add E.nil locs) [] in
|
||||
let _ = L.printf 3 "z: %a" E.fmt (E.mkAnd (Array.of_list z)) in
|
||||
(* let b = E.mkAnd (aux ExpMSet.empty sh []) in *)
|
||||
let _ps, c, d = SH.pure_consequences sh in
|
||||
let b = E.mkAnd [|c; d; (E.mkAnd (Array.of_list z))|] in
|
||||
(xs, b)
|
||||
|
||||
|
||||
let emit_moves buf pos xs_to_es =
|
||||
S.iter (fun x e ->
|
||||
match E.desc x with
|
||||
| E.Var(x) -> emit_move buf pos x e
|
||||
| _ -> L.printf 3 "Instrumentation: Dropped %a := %a" E.fmt x E.fmt e
|
||||
) xs_to_es
|
||||
|
||||
|
||||
let emit_transition buf pos p _blk_start blk blk_end r =
|
||||
L.incf 1 "( emit_transition:@ @[<hv>%a@ @[%a@]@ %a@]"
|
||||
XSH.fmt p (List.fmt ";@ " I.fmt) blk XSH.fmt r
|
||||
;
|
||||
let exists_bind_subst vs xsh =
|
||||
let xs, sh = XSH.exists_bind Vars.empty xsh in
|
||||
let ws, xs_m_vs = Vars.inter_diff xs vs in
|
||||
let sh', ws', ws_to_ws', ws'_to_ws = SH.rename_vs ws sh in
|
||||
(Vars.union ws' xs_m_vs, ws', sh', ws_to_ws', ws'_to_ws)
|
||||
in
|
||||
let ms =
|
||||
List.fold (fun i ms ->
|
||||
match i.I.desc with
|
||||
| I.Load(v,_) | I.Alloc(v,_) | I.Move(v,_) | I.Cast(v,_,_) -> Vars.add v ms
|
||||
| I.Kill(vs) -> Vars.union vs ms
|
||||
| I.Store _ | I.Free _ | I.Assume _ | I.Assert _ -> ms
|
||||
| _ -> failwithf "Instrumentation: unimplemented command: %a" I.fmt i
|
||||
) blk Vars.empty
|
||||
in
|
||||
let ms', ms'_to_ms =
|
||||
Vars.fold (fun v (fs,i) ->
|
||||
let sort = Var.sort v in
|
||||
let fresh = Var.gensym (Var.name v) sort in
|
||||
let i' = S.add (E.mkVar fresh) (E.mkVar v) i in
|
||||
(Vars.add fresh fs, i')
|
||||
) ms (Vars.empty, S.empty)
|
||||
in
|
||||
let tr_for r =
|
||||
let xs, vs', r', vs_to_vs', _ = exists_bind_subst (XSH.fv p) r in
|
||||
let ys, ws', p', _, ws'_to_ws = exists_bind_subst (SH.fv r') p
|
||||
in
|
||||
let p' = SH.Pf.star (S.fold (fun m' m acc -> E.mkEq m' m :: acc) ms'_to_ms []) p'
|
||||
in
|
||||
let cxt = Vars.unions [xs; ys; ms']
|
||||
in
|
||||
let q =
|
||||
match
|
||||
List.fold_left (fun q i ->
|
||||
SymbolicExecution.exec_inst cxt i q
|
||||
) (Some (SH.exists_intro Vars.empty p')) blk
|
||||
with
|
||||
| Some(q) ->
|
||||
if (K.sort blk_end) = Some K.Exit then
|
||||
(* exiting scope of locals, so quantify them *)
|
||||
let proc = KH.find enclosing_proc (K.id blk_end) in
|
||||
XSH.exists_intro proc.Proc.locals q
|
||||
else
|
||||
q
|
||||
| None -> failwithf "Instrumentation: symbolic execution failed"
|
||||
in
|
||||
let us, q = XSH.exists_bind cxt q
|
||||
in
|
||||
match Prover.entails q xs r' with
|
||||
| Some(tr) -> Some(xs, vs', vs_to_vs', ws', ws'_to_ws, cxt, XSH.exists_intro us tr)
|
||||
| None -> None
|
||||
in
|
||||
let xs, vs', vs_to_vs', ws', ws'_to_ws, cxt, tr =
|
||||
match tr_for r with
|
||||
| Some(xs, vs', vs_to_vs', ws', ws'_to_ws, cxt, tr) -> (xs, vs', vs_to_vs', ws', ws'_to_ws, cxt, tr)
|
||||
| None ->
|
||||
(* r need not have well-guarded quantifiers, so abstract to collect garbage and retry *)
|
||||
let r',_ = Abstraction.abstract r in
|
||||
match tr_for r' with
|
||||
| Some(xs, vs', vs_to_vs', ws', ws'_to_ws, cxt, tr) -> (xs, vs', vs_to_vs', ws', ws'_to_ws, cxt, tr)
|
||||
| None ->
|
||||
L.printf 1 "Instrumentation: failed to construct transition relation" ;
|
||||
(Vars.empty, Vars.empty, S.empty, Vars.empty, S.empty, Vars.empty, XSH.emp)
|
||||
in
|
||||
let zs, tr_bx = approximate cxt (XSH.normalize tr)
|
||||
in
|
||||
let rs = E.fv tr_bx in
|
||||
let ws'_to_ws = S.restrict rs ws'_to_ws
|
||||
and ms'_to_ms = S.restrict rs ms'_to_ms
|
||||
and vs_to_vs' = S.restrict_rng rs vs_to_vs'
|
||||
and ms = Vars.inter ms rs
|
||||
and xs = Vars.inter xs rs
|
||||
and ms' = Vars.inter ms' rs
|
||||
and vs' = Vars.inter vs' rs
|
||||
and ws' = Vars.inter ws' rs
|
||||
in
|
||||
(* rename from vocabulary of precondition to vocabulary of transition relation *)
|
||||
emit_moves buf pos ws'_to_ws ;
|
||||
(* copy modified variables *)
|
||||
emit_moves buf pos ms'_to_ms ;
|
||||
(* kill modified variables, and existentials of transition relation formula *)
|
||||
emit_kill buf pos (Vars.unions [ms; xs; zs]) ;
|
||||
(* constrain values of modified and existential variables *)
|
||||
emit_assume buf pos tr_bx ;
|
||||
(* rename from vocabulary of transition relation to vocabulary of postcondition *)
|
||||
emit_moves buf pos vs_to_vs' ;
|
||||
(* kill temporary variables *)
|
||||
emit_kill buf pos (Vars.unions [vs'; ws'; ms'])
|
||||
;
|
||||
L.decf 1 ") emit_transition:@\n@[<v>\
|
||||
ws'_to_ws: %a@ ms'_to_ms: %a@ xs: @[%a@]@ zs: @[%a@]@ tr: %a@ vs_to_vs': %a@]"
|
||||
S.fmt ws'_to_ws S.fmt ms'_to_ms Vars.fmt xs Vars.fmt zs E.fmt tr_bx S.fmt vs_to_vs'
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Convert SLAyer Abstract Transition Systems to T2 program syntax
|
||||
============================================================================*)
|
||||
|
||||
|
||||
module ID = Analysis.InterprocDomain
|
||||
module Tr = ID.Tr
|
||||
module ATS = ID.ATS
|
||||
|
||||
let emit_edge buf m error_state id0 p0 (v1, tr) =
|
||||
Printf.bprintf buf "FROM: %d;\n" id0 ;
|
||||
let r1, cp1 = ID.I_D_cp.project v1 in
|
||||
let xshT1 = ID.RD.project r1 in
|
||||
let id1 = ATS.VertexIMap.find m v1 in
|
||||
match xshT1 with
|
||||
| None ->
|
||||
Printf.bprintf buf "TO: %s;\n\n" error_state
|
||||
| Some(xsh1) ->
|
||||
(match tr with
|
||||
| Tr.Intra(blk_start, blk, blk_end, _) ->
|
||||
emit_transition buf (K.pos cp1) p0 blk_start blk blk_end xsh1
|
||||
| Tr.Call _
|
||||
| Tr.Return
|
||||
| Tr.Summary ->
|
||||
failwith "Unsupported: Instrumentation of non-inlined procedures"
|
||||
);
|
||||
Printf.bprintf buf "TO: %d;\n\n" id1
|
||||
|
||||
|
||||
(** Print the arithmetic commands originating from the vertex [v0]. *)
|
||||
let emit_vertex buf m error_state v0 id0 =
|
||||
let xshT0 = ID.RD.project (fst (ID.I_D_cp.project v0)) in
|
||||
L.printf 4 "[Instrumentation] emit_vertex %a" ATS.Vertex.fmt v0;
|
||||
match xshT0 with
|
||||
| None ->
|
||||
Printf.bprintf buf "FROM: %s;\nTO: %s;\n\n" error_state error_state
|
||||
| Some p0 ->
|
||||
List.iter
|
||||
(fun v_tr -> emit_edge buf m error_state id0 p0 v_tr)
|
||||
(ATS.successors v0)
|
||||
|
||||
|
||||
(** Generate arithmetic program in T2's input format. *)
|
||||
let write_arith_program {Prog.main; procs} ({Analysis.invariants} as results) buf =
|
||||
let ats = ID.ats invariants in
|
||||
let m = ATS.identify_vertices ats in
|
||||
(* Find start vertex *)
|
||||
let {Proc.entry} = Proc.IdHMap.find procs main in
|
||||
let start =
|
||||
match ATS.vertices_for ats entry with
|
||||
| [v] -> ATS.VertexIMap.find m v
|
||||
| _ -> failwith "abstract transition system must have a unique start"
|
||||
in
|
||||
(* Is this ATS a proof or a counterexample? *)
|
||||
let error_state =
|
||||
if Analysis.safe results then "ERROR"
|
||||
else string_of_int (ATS.VertexIMap.length m)
|
||||
in
|
||||
(* Output the program *)
|
||||
if not (Analysis.safe results) then (
|
||||
Printf.bprintf buf "// Counterexample error state: %s\n" error_state
|
||||
);
|
||||
Printf.bprintf buf "START: %d;\n\n" start;
|
||||
ATS.VertexIMap.iter (fun v id -> emit_vertex buf m error_state v id) m
|
||||
|
||||
|
||||
let instrument program results =
|
||||
let {Prog.main; procs} = program in
|
||||
let main = Proc.IdHMap.find procs main in
|
||||
if not Config.instrument then ()
|
||||
else
|
||||
let instr_fname = if Analysis.safe results then (Config.testname^".t2") else (Config.testname^".cex.t2") in
|
||||
Prog.fold_proc (Some procs)
|
||||
(fun _ () -> ())
|
||||
(fun _ () -> ())
|
||||
(fun p k () -> KH.add enclosing_proc (K.id k) p)
|
||||
(fun _ _ () -> ())
|
||||
main () ;
|
||||
try
|
||||
Library.with_out instr_fname (write_arith_program program results)
|
||||
with exc ->
|
||||
prerr_endline ("\nInstrumentation Error: "^(Printexc.to_string exc))
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open Variable
|
||||
open Expression
|
||||
open SymbolicHeap
|
||||
open Program
|
||||
|
||||
|
||||
val instrument : Prog.t -> Analysis.t -> unit
|
||||
|
||||
|
||||
val approximate : Vars.t -> XSH.t -> Vars.t * Exp.t
|
||||
|
|
@ -0,0 +1,407 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Interprocedural abstract fixed-point computation *)
|
||||
|
||||
(**/**)
|
||||
open Library
|
||||
|
||||
open Variable
|
||||
module S = Substitution
|
||||
open Program
|
||||
module I = Inst
|
||||
module C = Cmnd
|
||||
module K = ControlPoint
|
||||
|
||||
include Interproc_sig
|
||||
|
||||
module L = (val Log.raw Config.vSE : Log.LOG)
|
||||
|
||||
|
||||
(* PS#193: change to a priority queue where the priorities are computed so as
|
||||
to attempt to mimic the denotational semantics *)
|
||||
module DepthFirstWorklist = struct
|
||||
type t = Nil | Cons of int * (t -> t) * t
|
||||
|
||||
let count = ref 0
|
||||
|
||||
let rec ids = function
|
||||
| Nil -> []
|
||||
| Cons(id,_,items) -> id :: ids items
|
||||
|
||||
let empty = Nil
|
||||
|
||||
let add item items =
|
||||
(fun items -> L.printf 5 "W.add: @[%a@]" (List.fmt " " Format.pp_print_int) (ids items)) <& let()=()in
|
||||
incr count ;
|
||||
Cons(!count, item, items)
|
||||
|
||||
let rem items =
|
||||
L.printf 5 "W.rem: @[%a@]" (List.fmt " " Format.pp_print_int) (ids items) ;
|
||||
match items with
|
||||
| Nil -> None
|
||||
| Cons(_,item,items) -> Some(item, items)
|
||||
end
|
||||
module W = DepthFirstWorklist
|
||||
|
||||
|
||||
|
||||
module Summaries (I_D_cp: INJECT_D_CONTROL_POINT) : sig
|
||||
type t
|
||||
val empty : unit -> t
|
||||
val await : t -> I_D_cp.t -> (I_D_cp.t -> W.t -> W.t) -> unit
|
||||
val add : t -> Proc.t -> I_D_cp.t -> I_D_cp.t -> W.t -> W.t
|
||||
val posts : t -> Proc.t -> I_D_cp.t -> I_D_cp.t list
|
||||
end = struct
|
||||
|
||||
module I_D_cpTbl =
|
||||
ImperativeMultiMap.Make
|
||||
(I_D_cp)
|
||||
(List.Set(struct type t = I_D_cp.t -> W.t -> W.t end))
|
||||
|
||||
module I_D_cp_Set = Set.Make(I_D_cp)
|
||||
|
||||
module ProcI_D_cpTbl =
|
||||
ImperativeMultiMap.Make
|
||||
(struct
|
||||
type t = Proc.t * I_D_cp.t
|
||||
let equal = equal_tup2 Proc.equal I_D_cp.equal
|
||||
let compare = compare_tup2 Proc.compare I_D_cp.compare
|
||||
end)
|
||||
(I_D_cp_Set)
|
||||
|
||||
type t = {
|
||||
waiting: I_D_cpTbl.t;
|
||||
triples: ProcI_D_cpTbl.t
|
||||
}
|
||||
|
||||
let empty () =
|
||||
{waiting= I_D_cpTbl.create (); triples= ProcI_D_cpTbl.create ()}
|
||||
|
||||
let await sums pre thunk = I_D_cpTbl.add sums.waiting pre thunk
|
||||
|
||||
let add sums fn pre post wl =
|
||||
ProcI_D_cpTbl.add sums.triples (fn,pre) post ;
|
||||
let waiting_on_pre = I_D_cpTbl.find sums.waiting pre
|
||||
in
|
||||
List.fold (fun waiting wl -> waiting post wl) waiting_on_pre wl
|
||||
|
||||
let posts sums fn entry =
|
||||
I_D_cp_Set.to_list (ProcI_D_cpTbl.find sums.triples (fn,entry))
|
||||
end
|
||||
|
||||
|
||||
|
||||
module Heights (I_D_cp: INJECT_D_CONTROL_POINT) = struct
|
||||
module M = ImperativeMap.Make(ControlPoint)
|
||||
|
||||
type t = int M.t
|
||||
|
||||
let create () = M.create ()
|
||||
|
||||
let exceeded t k =
|
||||
let n = try (M.find t k) + 1 with Not_found -> 1 in
|
||||
M.add t k n ;
|
||||
(0 < Config.limit && Config.limit < n)
|
||||
end
|
||||
|
||||
|
||||
|
||||
module Pair (Inv: INTRAPROC_DOMAIN) = struct
|
||||
|
||||
type pred = Inv.t
|
||||
|
||||
type r = Inv.r
|
||||
let create = Inv.create
|
||||
|
||||
type t = { entry: Inv.t; curr: Inv.t; }
|
||||
|
||||
let inject x = {entry= x; curr= x}
|
||||
let project x = x.curr
|
||||
|
||||
let exec_inst cxt i x = {x with curr= Inv.exec_inst cxt i x.curr}
|
||||
|
||||
let error = inject Inv.error
|
||||
let tt = inject Inv.tt
|
||||
let is_error x = Inv.is_error x.curr
|
||||
let is_false x = Inv.is_false x.curr
|
||||
|
||||
let join x y = {x with curr= Inv.join x.curr y.curr}
|
||||
|
||||
let generalize x =
|
||||
let x', junk = Inv.generalize x.curr in
|
||||
({x with curr= x'}, junk)
|
||||
|
||||
(* equality on abstract elements at procedure entry points *)
|
||||
let equal_entry x y = Inv.equal x.entry y.entry
|
||||
|
||||
let below x y = equal_entry x y && Inv.below x.curr y.curr
|
||||
|
||||
let adapted_pre_substate_call r cxt pre call pcall =
|
||||
match Inv.adapted_pre_substate_call r cxt pre.curr call.curr pcall with
|
||||
| None -> None
|
||||
| Some(post_ra_to_retn_ra) ->
|
||||
let post_to_retn post_er =
|
||||
(* pop call stack by reinstating call's entry *)
|
||||
{call with curr= post_ra_to_retn_ra post_er.curr}
|
||||
in
|
||||
Some(post_to_retn)
|
||||
|
||||
let call_to_entry r call pcall =
|
||||
let entry, post_ra_to_retn_ra = Inv.call_to_entry r call.curr pcall
|
||||
in
|
||||
let post_to_retn post_er =
|
||||
(* pop call stack by reinstating call's entry *)
|
||||
{call with curr= post_ra_to_retn_ra post_er.curr}
|
||||
in
|
||||
(inject entry, post_to_retn)
|
||||
|
||||
let exit_to_retn callee exit =
|
||||
{exit with curr= Inv.exit_to_retn callee exit.curr}
|
||||
|
||||
let resolve_indirect_call r call fptr ftyp =
|
||||
Inv.resolve_indirect_call r call.curr fptr ftyp
|
||||
|
||||
let compare x y =
|
||||
compare_tup2 Inv.compare Inv.compare (x.entry,x.curr) (y.entry,y.curr)
|
||||
|
||||
let equal x y = Inv.equal x.curr y.curr && Inv.equal x.entry y.entry
|
||||
|
||||
let fmt ff x = Inv.fmt ff x.curr
|
||||
let fmt_entry ff x = Inv.fmt ff x.entry
|
||||
let fmt_pre ff (x,p) = Inv.fmt_pre ff (x.curr,p)
|
||||
let fmt_reln ff x =
|
||||
Format.fprintf ff "(@[%a,@ %a@])" Inv.fmt x.entry Inv.fmt x.curr
|
||||
|
||||
end (* Pair *)
|
||||
|
||||
|
||||
|
||||
module Make (InterprocDomain: INTERPROC_DOMAIN) = struct
|
||||
|
||||
module ID = InterprocDomain
|
||||
module PInv = ID.RD (* a pair of invariants *)
|
||||
module InjPInv = ID.I_D_cp (* a pair of invariants injected into the InterprocDomain carrier *)
|
||||
|
||||
|
||||
module Summaries = Summaries(InjPInv)
|
||||
|
||||
let fmt_summary lvl msg pre ({Proc.formals; freturn} as proc) post =
|
||||
L.printf lvl "@[<hov 2>%s summary:@ @[<hv>%a@ %a@ %a@]@\n" msg
|
||||
PInv.fmt_pre (fst (InjPInv.project pre), proc)
|
||||
(Call.fmt (fun ff {Proc.id} -> Proc.Id.fmt ff id)) (Call.mk proc formals freturn)
|
||||
PInv.fmt (fst (InjPInv.project post))
|
||||
|
||||
|
||||
module Heights = Heights(InjPInv)
|
||||
|
||||
|
||||
type t = {
|
||||
program: Prog.t;
|
||||
invariants: ID.r;
|
||||
summaries: Summaries.t;
|
||||
heights: Heights.t;
|
||||
mutable safe: bool;
|
||||
mutable hit_limit: bool;
|
||||
}
|
||||
|
||||
|
||||
let exec_prog ({Prog.globals; procs; main} as program) init =
|
||||
let r = ID.create program in
|
||||
let sums = Summaries.empty () in
|
||||
let heights = Heights.create () in
|
||||
let res = {program; invariants= r; summaries= sums; heights; safe= true; hit_limit= false}
|
||||
in
|
||||
let rec exec_cont
|
||||
(proc: Proc.t) (* proc currently executing *)
|
||||
((prev: InjPInv.t), (* invariant for previous "control point" *)
|
||||
((curr: PInv.t), (* invariant for current cont *)
|
||||
(pc: K.t)) (* current cont / program counter *)
|
||||
as prev_to_curr: ID.d_bk) (* path edge from prev to curr points *)
|
||||
wl (* worklist *)
|
||||
=
|
||||
let cxt = Vars.union globals proc.Proc.locals in
|
||||
|
||||
let fail ((prev, (_error, _k)) as prev_to_error) wl =
|
||||
res.safe <- false ;
|
||||
let next = ID.prev_to_join r prev_to_error in
|
||||
if Config.propagate then
|
||||
W.add (exec_cont proc (prev, (InjPInv.project next))) wl
|
||||
else if Config.continue then
|
||||
wl
|
||||
else
|
||||
W.empty
|
||||
in
|
||||
|
||||
let rec exec_succ ((prev, (curr, pc)) as prev_to_curr) cmnd k wl =
|
||||
match cmnd with
|
||||
| C.Inst(inst) ->
|
||||
L.incf 3 " %a@\n@[<hov 2>exec: %a@\n%a@]" PInv.fmt curr Position.fmt (K.pos pc) I.fmt inst ;
|
||||
(fun _ -> L.decf 3 "@ ")
|
||||
<&
|
||||
let prev_to_k = PInv.exec_inst cxt inst curr in
|
||||
if PInv.is_error prev_to_k then
|
||||
let curr = if K.sort pc <> None then prev else ID.prev_to_join r prev_to_curr in
|
||||
let curr_to_error = PInv.exec_inst cxt inst (fst (InjPInv.project curr)) in
|
||||
fail (curr, (curr_to_error, k)) wl
|
||||
else
|
||||
W.add (exec_cont proc (prev, (prev_to_k, k))) wl
|
||||
|
||||
| C.Call({Call.proc= callee_name} as pcall) ->
|
||||
L.printf 2 " %a@\n@[<hov 2>exec: @[%a@]@\n%a@\n@]" PInv.fmt curr K.fmt pc C.fmt cmnd
|
||||
;
|
||||
let callee =
|
||||
try Proc.IdHMap.find procs callee_name
|
||||
with Not_found -> failwithf "Undefined procedure: %a" Proc.Id.fmt callee_name
|
||||
in
|
||||
let exec_post_to_retn pre post_to_retn post wl =
|
||||
let retn = post_to_retn (post, (fst (ID.I_D_cp.project post), k))
|
||||
in
|
||||
fmt_summary 2 "applying" pre callee post ;
|
||||
(* execute from the return site *)
|
||||
W.add (exec_cont proc (retn, ID.I_D_cp.project retn)) wl
|
||||
in
|
||||
let apply_existing_summary pre post_to_retn wl =
|
||||
(* pre covers call *)
|
||||
let exec_post_to_retn = exec_post_to_retn pre post_to_retn
|
||||
in
|
||||
(* execute this call's return site from any posts added to this specification later *)
|
||||
Summaries.await sums pre exec_post_to_retn
|
||||
;
|
||||
(* execute this call's return site from the existing summary's post states *)
|
||||
List.fold exec_post_to_retn (Summaries.posts sums callee pre) wl
|
||||
in
|
||||
let create_new_summary entry post_to_retn wl =
|
||||
(* execute this call's return site from any posts added to this specification later *)
|
||||
Summaries.await sums entry (exec_post_to_retn entry post_to_retn)
|
||||
;
|
||||
(* execute the callee's body *)
|
||||
W.add (exec_cont callee (entry, ID.I_D_cp.project entry)) wl
|
||||
in
|
||||
let pres = ID.procedure_pres r callee
|
||||
in
|
||||
let rec search_for_covering_pre = function
|
||||
| [] ->
|
||||
(* no covering pre, compute a new specification *)
|
||||
L.printf 7 "@[<hov 2>no summary for:@ %a@]" PInv.fmt curr
|
||||
;
|
||||
let entry, post_to_retn = ID.call_to_entry r prev_to_curr {pcall with Call.proc= callee}
|
||||
in
|
||||
if List.exists (fun pre -> InjPInv.equal entry pre) pres then
|
||||
apply_existing_summary entry post_to_retn wl
|
||||
else
|
||||
create_new_summary entry post_to_retn wl
|
||||
| pre :: pres ->
|
||||
(* found a pre *)
|
||||
L.printf 7 "@[<hov 2>trying summary with pre:@ %a@]" PInv.fmt (fst (InjPInv.project pre))
|
||||
;
|
||||
(* check if pre covers call *)
|
||||
match ID.adapted_pre_substate_call r cxt pre prev_to_curr {pcall with Call.proc= callee} with
|
||||
| None ->
|
||||
(* no, keep looking *)
|
||||
search_for_covering_pre pres
|
||||
| Some(post_to_retn) ->
|
||||
(* pre covers call *)
|
||||
apply_existing_summary pre post_to_retn wl
|
||||
in
|
||||
(* find all preconditions for callee *)
|
||||
search_for_covering_pre pres
|
||||
|
||||
| C.ICall({Call.proc; typ; targets} as pcall) ->
|
||||
L.printf 2 " %a@\n@[<hov 2>exec: @[%a@]@\n%a@\n@]" PInv.fmt curr K.fmt pc C.fmt cmnd
|
||||
;
|
||||
let callees = ID.resolve_indirect_call r prev_to_curr proc typ in
|
||||
if callees = [] then
|
||||
let curr = ID.prev_to_join r prev_to_curr in
|
||||
let curr_to_error = PInv.join (fst (InjPInv.project curr)) PInv.error in
|
||||
fail (curr, (curr_to_error, k)) wl
|
||||
else
|
||||
List.fold (fun callee wl ->
|
||||
if not (List.exists (fun target -> Proc.Id.equal callee target) targets) then
|
||||
failwith "Unsound static approximation of indirect call targets" ;
|
||||
exec_succ prev_to_curr (C.Call({pcall with Call.proc= callee})) k wl
|
||||
) callees wl
|
||||
in
|
||||
|
||||
(* exec_cont *)
|
||||
if PInv.is_false curr then (
|
||||
(* don't execute if curr is inconsistent *)
|
||||
L.printf 3 " %a@\n@[<hov 2>exec: @[%a@]@]@\nunreachable@\n" PInv.fmt curr K.fmt pc ;
|
||||
if Config.show_unreachable then ignore( ID.prev_to_join r prev_to_curr );
|
||||
wl
|
||||
) else if ID.now_covered r prev then (
|
||||
(* don't execute if pre got covered since it was scheduled *)
|
||||
L.printf 3 " %a@\n@[<hov 2>exec: @[%a@]@]@\n@[covered:@ %a@]@\n" PInv.fmt curr K.fmt pc InjPInv.fmt prev ;
|
||||
wl
|
||||
) else if Heights.exceeded heights pc then (
|
||||
(* fail if limit on number of iterations is hit *)
|
||||
L.printf 3 " %a@\n@[<hov 2>exec: @[%a@]@\nchain too long@]@\n" PInv.fmt curr K.fmt pc ;
|
||||
res.hit_limit <- true ;
|
||||
fail prev_to_curr wl
|
||||
) else (
|
||||
let exec_succs ((_prev, (_curr, pc)) as prev_to_curr) wl =
|
||||
List.fold (fun (k, edge) wl ->
|
||||
exec_succ prev_to_curr edge k wl
|
||||
) (CFG.successors pc) wl
|
||||
in
|
||||
match K.sort pc with
|
||||
| Some K.Exit ->
|
||||
let prev_to_retn = ID.exit_to_retn proc prev_to_curr
|
||||
in
|
||||
let covered, retn = ID.prev_to_cut r prev_to_retn
|
||||
in
|
||||
(match covered with
|
||||
| ID.WasCoveredByOld ->
|
||||
wl
|
||||
| ID.NowCoveredByNew ->
|
||||
let pre =
|
||||
let equal_entry x y = ID.RD.equal_entry (fst (ID.I_D_cp.project x)) (fst (ID.I_D_cp.project y)) in
|
||||
try
|
||||
List.find (equal_entry retn) (ID.procedure_pres r proc)
|
||||
with Not_found ->
|
||||
L.printf 2 "@[retn:@ @[%a@]@ pres:@ @[%a@]@]"
|
||||
PInv.fmt_reln (fst (InjPInv.project retn))
|
||||
(List.fmt ",@ " (fun ff pre -> PInv.fmt ff (fst (InjPInv.project pre))))
|
||||
(ID.procedure_pres r proc) ;
|
||||
failwith "no pre for retn found"
|
||||
in
|
||||
fmt_summary 1 "adding" pre proc retn
|
||||
;
|
||||
ID.register_pre r pre
|
||||
;
|
||||
Summaries.add sums proc pre retn wl
|
||||
)
|
||||
| Some K.Cut ->
|
||||
let covered, cut = ID.prev_to_cut r prev_to_curr in
|
||||
(match covered with
|
||||
| ID.WasCoveredByOld ->
|
||||
wl
|
||||
| ID.NowCoveredByNew ->
|
||||
exec_succs (cut, ID.I_D_cp.project cut) wl
|
||||
)
|
||||
| Some K.Join ->
|
||||
let join = ID.prev_to_join r prev_to_curr in
|
||||
exec_succs (join, ID.I_D_cp.project join) wl
|
||||
|
||||
| Some K.Fork ->
|
||||
let fork = ID.prev_to_join r prev_to_curr in
|
||||
exec_succs (fork, ID.I_D_cp.project fork) wl
|
||||
|
||||
| Some K.Entry | Some K.Return | None ->
|
||||
exec_succs prev_to_curr wl
|
||||
)
|
||||
in
|
||||
(* exec_prog *)
|
||||
let rec compute_invariants_fixed_point wl =
|
||||
match W.rem wl with
|
||||
| Some(thunk, wl) ->
|
||||
compute_invariants_fixed_point (thunk wl)
|
||||
| None ->
|
||||
res
|
||||
in
|
||||
let {Proc.entry} as main = Proc.IdHMap.find procs main
|
||||
in
|
||||
let init = ID.init r (PInv.inject init, entry)
|
||||
in
|
||||
compute_invariants_fixed_point (W.add (exec_cont main (init, ID.I_D_cp.project init)) W.empty)
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Interprocedural abstract fixed-point computation *)
|
||||
|
||||
open Program
|
||||
open Interproc_sig
|
||||
|
||||
|
||||
module Pair (Inv: INTRAPROC_DOMAIN) : (RELATION_DOMAIN with type pred = Inv.t)
|
||||
|
||||
|
||||
(** Construct an interprocedural analysis given a domain for representing sets
|
||||
of states and an interprocedural domain, parametric in the intraprocedural
|
||||
domain and in the lifting from intraprocedural abstract states to
|
||||
interprocedural abstract states *)
|
||||
module Make (InterprocDomain: INTERPROC_DOMAIN) : sig
|
||||
|
||||
module Summaries : sig type t end
|
||||
module Heights : sig type t end
|
||||
|
||||
type t = {
|
||||
program: Prog.t;
|
||||
invariants: InterprocDomain.r;
|
||||
summaries: Summaries.t;
|
||||
heights: Heights.t;
|
||||
mutable safe: bool;
|
||||
mutable hit_limit: bool;
|
||||
}
|
||||
|
||||
val exec_prog : Prog.t -> InterprocDomain.RD.pred -> t
|
||||
end
|
||||
|
|
@ -0,0 +1,172 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Interfaces for analysis modules *)
|
||||
|
||||
(**/**)
|
||||
open Library
|
||||
|
||||
open Type
|
||||
open Variable
|
||||
open Expression
|
||||
open Program
|
||||
(**/**)
|
||||
|
||||
|
||||
module type PROCEDURE_OPERATIONS = sig
|
||||
type i_d_cp (** (injected) data associated with control points *)
|
||||
type d_bk (** data associated with control point free paths *)
|
||||
|
||||
type r (** domain-specific whole-program data *)
|
||||
val create : Prog.t -> r
|
||||
|
||||
(** For procedure p given by p(f)\{local l in B\}, we use the following
|
||||
naming conventions for variables denoting abstract predicates based on
|
||||
the roles they play in judgments of the form
|
||||
{C \{pre\} p(f) \{post\} |- \{entry\} B \{exit\} }
|
||||
or {C \{pre\} p(f) \{post\} |- \{call\} p(f\[A/f\]) \{retn\} } *)
|
||||
|
||||
(** For a procedure call \{call\} p(f\[A\]), [adapted_pre_substate_call r
|
||||
cxt pre call p \[A/f\]] determines if a summary from [pre] applies to
|
||||
the call and if so executes an interprocedural step to [pre] and returns
|
||||
[post_to_retn] such that for any specification \{pre\} p(f) \{\/_i
|
||||
post_i\}, [post_to_retn caller post_i] executes an intraprocedural post
|
||||
to return site step such that \{pre\} p(f\[A/f\]) \{\/_i post_to_retn
|
||||
post_i\} holds. *)
|
||||
val adapted_pre_substate_call : r -> Vars.t -> i_d_cp -> d_bk -> Proc.t Call.t -> (d_bk -> i_d_cp) option
|
||||
|
||||
(** For a procedure call \{call\} p(A), [call_to_entry r call p A] executes
|
||||
an interprocedural call site to entry point step, returning a [pre]
|
||||
such that a specification \{pre\} p(x) \{post\} would apply. *)
|
||||
val call_to_entry : r -> d_bk -> Proc.t Call.t -> i_d_cp * (d_bk -> i_d_cp)
|
||||
|
||||
(** [exit_to_retn p exit] executes an interprocedural exit point to return
|
||||
site step, returning [retn] such that if \{entry\} B \{exit\} holds
|
||||
where [p] is given by p(x)\{local l in B\}, then
|
||||
\{entry\} local l in B \{retn\} holds. *)
|
||||
val exit_to_retn : Proc.t -> d_bk -> d_bk
|
||||
|
||||
(** [resolve_indirect_call r call fptr ftyp] returns an over-approximation of the possible procedures that
|
||||
[*fptr] of type [ftyp] in states satisfying [call] might call. *)
|
||||
val resolve_indirect_call : r -> d_bk -> Exp.t -> Typ.t -> Proc.Id.t list
|
||||
end
|
||||
|
||||
|
||||
(** An abstract domain for intraprocedural analysis *)
|
||||
module type INTRAPROC_DOMAIN = sig
|
||||
|
||||
type t
|
||||
|
||||
include
|
||||
(PROCEDURE_OPERATIONS
|
||||
with type i_d_cp := t
|
||||
and type d_bk := t)
|
||||
|
||||
|
||||
(** element representing all error states *)
|
||||
val error : t
|
||||
|
||||
(** element representing all non-error states *)
|
||||
val tt : t
|
||||
|
||||
(** test if element represents error states *)
|
||||
val is_error : t -> bool
|
||||
|
||||
(** test if element represents no states *)
|
||||
val is_false : t -> bool
|
||||
|
||||
(** execution of instructions *)
|
||||
val exec_inst : Vars.t -> Inst.t -> t -> t
|
||||
|
||||
(** abstract order *)
|
||||
val below : t -> t -> bool
|
||||
|
||||
(** abstract element constructors *)
|
||||
val join : t -> t -> t
|
||||
val generalize : t -> t * bool
|
||||
|
||||
(** utility routines *)
|
||||
val compare : t -> t -> int
|
||||
val equal : t -> t -> bool
|
||||
val fmt : t formatter
|
||||
val fmt_pre : (t * Proc.t) formatter
|
||||
end
|
||||
|
||||
|
||||
|
||||
(** An abstract domain for intraprocedural analysis, but using a form of
|
||||
abstract states suitable for interprocedural analysis *)
|
||||
module type RELATION_DOMAIN = sig
|
||||
include (INTRAPROC_DOMAIN)
|
||||
val equal_entry : t -> t -> bool
|
||||
val fmt_entry : t formatter
|
||||
val fmt_reln : t formatter
|
||||
|
||||
type pred
|
||||
val inject : pred -> t
|
||||
val project : t -> pred
|
||||
end
|
||||
|
||||
|
||||
|
||||
(** Intraprocedural abstract states (a d_cp and a control_point) together with
|
||||
other domain-specific data *)
|
||||
module type INJECT_D_CONTROL_POINT = sig
|
||||
type t
|
||||
type d_cp
|
||||
|
||||
val project : t -> d_cp * ControlPoint.t
|
||||
|
||||
val equal : t -> t -> bool
|
||||
val compare : t -> t -> int
|
||||
val fmt : t formatter
|
||||
end
|
||||
|
||||
|
||||
|
||||
(** An abstract domain for interprocedural analysis *)
|
||||
module type INTERPROC_DOMAIN = sig
|
||||
module RD : RELATION_DOMAIN
|
||||
|
||||
module I_D_cp : (INJECT_D_CONTROL_POINT with type d_cp = RD.t)
|
||||
|
||||
include
|
||||
(PROCEDURE_OPERATIONS
|
||||
with type i_d_cp = I_D_cp.t
|
||||
and type d_bk = I_D_cp.t * (RD.t * ControlPoint.t))
|
||||
|
||||
|
||||
(** [init r p] is the initial element for [p] *)
|
||||
val init : r -> RD.t * ControlPoint.t -> i_d_cp
|
||||
|
||||
|
||||
(** [now_covered r p] tests if [p] is covered by some other element *)
|
||||
val now_covered : r -> i_d_cp -> bool
|
||||
|
||||
(** [prev_to_join r (prev,(prev_to,next))] executes an intraprocedural
|
||||
step to a join point *)
|
||||
val prev_to_join : r -> d_bk -> i_d_cp
|
||||
|
||||
(** [prev_to_cut r (prev,(prev_to,next))] executes an intraprocedural
|
||||
step to a cut point *)
|
||||
type __covered = WasCoveredByOld | NowCoveredByNew
|
||||
val prev_to_cut : r -> d_bk -> __covered * i_d_cp
|
||||
|
||||
|
||||
(** [procedure_pres r proc] are the pres of all summaries of [proc] *)
|
||||
val procedure_pres : r -> Proc.t -> i_d_cp list
|
||||
|
||||
(** [register_pre r pre] declares that [pre] is the pre of some summary *)
|
||||
val register_pre : r -> i_d_cp -> unit
|
||||
|
||||
|
||||
val states_for : r -> ControlPoint.t -> I_D_cp.t list
|
||||
|
||||
val errors : r -> I_D_cp.t list
|
||||
|
||||
val leaks : r -> I_D_cp.t list
|
||||
|
||||
val dead : r -> Position.t list
|
||||
|
||||
val hit_limit : r -> bool
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(* Extensions of the standard library *)
|
||||
|
||||
(* Note:
|
||||
- review the various set modules and make their interfaces
|
||||
consistent with each other and equally complete
|
||||
*)
|
||||
|
||||
|
||||
include NSLib
|
||||
|
||||
include NSArray
|
||||
include NSOption
|
||||
include NSList
|
||||
include NSSortedList
|
||||
include NSTuple
|
||||
include NSSet
|
||||
include NSMultiSet
|
||||
(* include NSPolySet *)
|
||||
include NSIndexedSet
|
||||
include NSMultiIndexedSet
|
||||
include NSMultiIndexedMultiSet
|
||||
include NSMap
|
||||
include NSMultiMap
|
||||
include NSImperativeMap
|
||||
include NSImperativeMultiMap
|
||||
include NSHashtbl
|
||||
include NSPolyHashMap
|
||||
include NSHashMap
|
||||
include NSHashMultiMap
|
||||
include NSImperativeSet
|
||||
include NSHashSet
|
||||
include NSBinaryRelation
|
||||
include NSString
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Extensions of the standard library. See also standard
|
||||
{{:file:../../../doc/ocaml%20manual/libref/index.html}Library}. *)
|
||||
|
||||
|
||||
include module type of NSLib
|
||||
|
||||
include module type of NSArray
|
||||
include module type of NSOption
|
||||
include module type of NSList
|
||||
include module type of NSSortedList
|
||||
include module type of NSTuple
|
||||
include module type of NSSet
|
||||
include module type of NSMultiSet
|
||||
(* include module type of NSPolySet *)
|
||||
include module type of NSIndexedSet
|
||||
include module type of NSMultiIndexedSet
|
||||
include module type of NSMultiIndexedMultiSet
|
||||
include module type of NSMap
|
||||
include module type of NSMultiMap
|
||||
include module type of NSImperativeMap
|
||||
include module type of NSImperativeMultiMap
|
||||
include module type of NSHashtbl
|
||||
include module type of NSPolyHashMap
|
||||
include module type of NSHashMap
|
||||
include module type of NSHashMultiMap
|
||||
include module type of NSImperativeSet
|
||||
include module type of NSHashSet
|
||||
include module type of NSBinaryRelation
|
||||
|
||||
(** {2 Extended Modules } *)
|
||||
include module type of NSString
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSList
|
||||
|
||||
|
||||
module Array = struct
|
||||
include Array
|
||||
|
||||
let swap a i j =
|
||||
let a_i = a.(i) in
|
||||
a.(i) <- a.(j) ;
|
||||
a.(j) <- a_i
|
||||
|
||||
let reverse a i j =
|
||||
let rec loop n =
|
||||
if n < j/2 then (
|
||||
swap a n (j-n-1) ;
|
||||
loop (j+1)
|
||||
)
|
||||
in
|
||||
loop i
|
||||
|
||||
let equal eq x y =
|
||||
let l = Array.length x in
|
||||
l = (Array.length y) &&
|
||||
let rec equal_ i =
|
||||
if i >= l then true else
|
||||
eq x.(i) y.(i) && equal_ (i+1)
|
||||
in equal_ 0
|
||||
|
||||
let compare cmp x y =
|
||||
let l = Array.length x in
|
||||
let o = Pervasives.compare l (Array.length y) in if o <> 0 then o else
|
||||
let rec compare_ i =
|
||||
if i >= l then 0 else
|
||||
let o = cmp x.(i) y.(i) in if o <> 0 then o else compare_ (i+1)
|
||||
in compare_ 0
|
||||
|
||||
let fmt sep fn ff a = List.fmt sep fn ff (to_list a)
|
||||
|
||||
let for_all pd a = Array.fold_right (fun x b -> b && pd x) a true
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
(** Operations on ['a array]. See also standard
|
||||
{{:file:../../../doc/ocaml%20manual/libref/Array.html}Array}. *)
|
||||
|
||||
module Array : sig
|
||||
|
||||
include module type of Array
|
||||
|
||||
val swap : 'a array -> int -> int -> unit
|
||||
|
||||
val reverse : 'a array -> int -> int -> unit
|
||||
|
||||
(* val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool *)
|
||||
val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
|
||||
val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
|
||||
|
||||
val fmt :
|
||||
(unit,Format.formatter,unit)format -> 'a formatter -> 'a array formatter
|
||||
|
||||
val for_all : ('a -> bool) -> 'a array -> bool
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSSet
|
||||
|
||||
|
||||
module BinaryRelation = struct
|
||||
module Make(Ord: OrderedType) = struct
|
||||
|
||||
module OrdOrd = struct
|
||||
type t = Ord.t * Ord.t
|
||||
let equal = equal_tup2 Ord.equal Ord.equal
|
||||
let compare = compare_tup2 Ord.compare Ord.compare
|
||||
end
|
||||
|
||||
include Set.Make (OrdOrd)
|
||||
|
||||
let inverse xs =
|
||||
map (fun (x,y) -> (y,x)) xs
|
||||
|
||||
let map_prod fn xs ys =
|
||||
fold (fun x -> fold (fun y -> add (fn x y)) ys) xs empty
|
||||
|
||||
let fold_product fn xs ys =
|
||||
fold (fun x -> fold (fun y -> fn x y) ys) xs
|
||||
|
||||
(* incremental transitive closure *)
|
||||
let add_with_closure (x,y) us =
|
||||
let ws = filter (fun (_,y) -> Ord.equal x y) us
|
||||
and zs = filter (fun (x,_) -> Ord.equal x y) us in
|
||||
us
|
||||
|> add (x,y)
|
||||
|> union (map (fun (w,_) -> (w,y)) ws)
|
||||
|> union (map (fun (_,z) -> (x,z)) zs)
|
||||
|> union (map_prod (fun (w,_) (_,z) -> (w,z)) ws zs)
|
||||
|
||||
let close xs =
|
||||
fold add_with_closure xs empty
|
||||
|
||||
let choose_maximal_path us =
|
||||
let rec segment x y seg =
|
||||
try
|
||||
(* search backward *)
|
||||
let w,_ =
|
||||
choose (filter (fun (w,z) ->
|
||||
Ord.equal x z && not (List.mem w seg)
|
||||
) us)
|
||||
in
|
||||
(segment w y (w :: seg))
|
||||
with Not_found ->
|
||||
try
|
||||
(* search forward *)
|
||||
let _,z =
|
||||
choose (filter (fun (w,z) ->
|
||||
Ord.equal y w && not (List.mem z seg)
|
||||
) us)
|
||||
in
|
||||
(segment x z (seg @ [z]))
|
||||
with Not_found ->
|
||||
[]
|
||||
in
|
||||
try
|
||||
let (x,y) = choose us in
|
||||
segment x y [x; y]
|
||||
with Not_found ->
|
||||
[]
|
||||
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSSet
|
||||
|
||||
|
||||
(** Binary Relations of ordered values. *)
|
||||
module BinaryRelation : sig
|
||||
module Make (Ord : OrderedType) : sig
|
||||
include Set.S with type elt = Ord.t * Ord.t
|
||||
val inverse : t -> t
|
||||
val fold_product : (elt -> elt -> 'z -> 'z) -> t -> t -> 'z -> 'z
|
||||
val close : t -> t
|
||||
val choose_maximal_path : t -> elt list
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSHashtbl
|
||||
|
||||
|
||||
module HashMap = struct
|
||||
module type S = sig
|
||||
type key
|
||||
type 'a t
|
||||
|
||||
val create : int -> 'a t
|
||||
val clear : 'a t -> unit
|
||||
val copy : 'a t -> 'a t
|
||||
val add : 'a t -> key -> 'a -> unit
|
||||
val remove : 'a t -> key -> unit
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
val length : 'a t -> int
|
||||
val mem : 'a t -> key -> bool
|
||||
val find : 'a t -> key -> 'a
|
||||
val tryfind : 'a t -> key -> 'a option
|
||||
|
||||
val iter : (key -> 'a -> unit) -> 'a t -> unit
|
||||
val exists : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val filter : (key -> 'a -> bool) -> 'a t -> unit
|
||||
val map : ('v -> 'w) -> 'v t -> 'w t
|
||||
val mapi : (key -> 'v -> 'w) -> 'v t -> 'w t
|
||||
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
end
|
||||
|
||||
module Make(H: HashedType) = struct
|
||||
include Hashtbl.Make(H)
|
||||
let add = replace
|
||||
end
|
||||
end
|
||||
|
||||
module StringHMap = HashMap.Make(struct
|
||||
type t = string
|
||||
let equal = (Pervasives.( = ) : string -> string -> bool)
|
||||
let hash = (Hashtbl.hash : string -> int)
|
||||
end)
|
||||
|
||||
module IntHMap = HashMap.Make(struct
|
||||
type t = int
|
||||
let equal = (Pervasives.( = ) : int -> int -> bool)
|
||||
let hash = (Hashtbl.hash : int -> int)
|
||||
end)
|
||||
|
||||
module Int64HMap = HashMap.Make(struct
|
||||
type t = int64
|
||||
let equal = (Pervasives.( = ) : int64 -> int64 -> bool)
|
||||
let hash = (Hashtbl.hash : int64 -> int)
|
||||
end)
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Imperative maps from hashed keys to single values. *)
|
||||
module HashMap : sig
|
||||
module type S = sig
|
||||
type key
|
||||
type 'a t
|
||||
|
||||
val create : int -> 'a t
|
||||
val clear : 'a t -> unit
|
||||
val copy : 'a t -> 'a t
|
||||
val add : 'a t -> key -> 'a -> unit
|
||||
val remove : 'a t -> key -> unit
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
val length : 'a t -> int
|
||||
val mem : 'a t -> key -> bool
|
||||
val find : 'a t -> key -> 'a
|
||||
val tryfind : 'a t -> key -> 'a option
|
||||
|
||||
val iter : (key -> 'a -> unit) -> 'a t -> unit
|
||||
val exists : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val filter : (key -> 'a -> bool) -> 'a t -> unit
|
||||
val map : ('v -> 'w) -> 'v t -> 'w t
|
||||
val mapi : (key -> 'v -> 'w) -> 'v t -> 'w t
|
||||
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
end
|
||||
|
||||
module Make (H : HashedType) : (S with type key = H.t)
|
||||
end
|
||||
|
||||
module IntHMap : (HashMap.S with type key = int)
|
||||
module Int64HMap : (HashMap.S with type key = int64)
|
||||
module StringHMap : (HashMap.S with type key = string)
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSHashtbl
|
||||
|
||||
|
||||
module HashMultiMap = struct
|
||||
module type S = sig
|
||||
type key
|
||||
type 'a t
|
||||
|
||||
val create : int -> 'a t
|
||||
val clear : 'a t -> unit
|
||||
val copy : 'a t -> 'a t
|
||||
val add : 'a t -> key -> 'a -> unit
|
||||
val remove : 'a t -> key -> unit
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
val length : 'a t -> int
|
||||
val mem : 'a t -> key -> bool
|
||||
val find : 'a t -> key -> 'a list
|
||||
|
||||
val iter : (key -> 'a -> unit) -> 'a t -> unit
|
||||
val exists : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val existsi : key -> ('a -> bool) -> 'a t -> bool
|
||||
(* val filter : (key -> 'a -> bool) -> 'a t -> unit *)
|
||||
(* val filteri : key -> ('a -> bool) -> 'a t -> unit *)
|
||||
(* val map : ('a -> 'a) -> 'a t -> unit *)
|
||||
(* val mapi : (key -> 'a -> 'a) -> 'a t -> unit *)
|
||||
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
end
|
||||
|
||||
module Make(H: HashedType) = struct
|
||||
include Hashtbl.Make(H)
|
||||
let find = find_all
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
module IntHMMap = HashMultiMap.Make(struct
|
||||
type t = int
|
||||
let equal = (Pervasives.( = ) : int -> int -> bool)
|
||||
let hash = (Hashtbl.hash : int -> int)
|
||||
end)
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Imperative maps from hashed keys to multiple values. *)
|
||||
module HashMultiMap : sig
|
||||
module type S = sig
|
||||
type key
|
||||
type 'a t
|
||||
|
||||
val create : int -> 'a t
|
||||
val clear : 'a t -> unit
|
||||
val copy : 'a t -> 'a t
|
||||
val add : 'a t -> key -> 'a -> unit
|
||||
val remove : 'a t -> key -> unit
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
val length : 'a t -> int
|
||||
val mem : 'a t -> key -> bool
|
||||
val find : 'a t -> key -> 'a list
|
||||
|
||||
val iter : (key -> 'a -> unit) -> 'a t -> unit
|
||||
val exists : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val existsi : key -> ('a -> bool) -> 'a t -> bool
|
||||
(* val filter : (key -> 'a -> bool) -> 'a t -> unit *)
|
||||
(* val filteri : key -> ('a -> bool) -> 'a t -> unit *)
|
||||
(* val map : ('a -> 'a) -> 'a t -> unit *)
|
||||
(* val mapi : (key -> 'a -> 'a) -> 'a t -> unit *)
|
||||
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
end
|
||||
|
||||
module Make (H : HashedType) : (S with type key = H.t)
|
||||
end
|
||||
|
||||
|
||||
module IntHMMap : HashMultiMap.S with type key = int
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSPolyHashMap
|
||||
|
||||
|
||||
(* Note: remove polymorphic interface *)
|
||||
module HashSet = struct
|
||||
type 'a t = ('a, unit) PolyHMap.t
|
||||
|
||||
let create = PolyHMap.create
|
||||
let add s x = PolyHMap.add s x ()
|
||||
let remove s x = PolyHMap.remove s x
|
||||
|
||||
let cardinal = PolyHMap.length
|
||||
let mem s x = PolyHMap.mem s x
|
||||
|
||||
let iter f = PolyHMap.iter (fun x () -> f x)
|
||||
let exists p = PolyHMap.exists (fun x () -> p x)
|
||||
let fold f = PolyHMap.fold (fun x () -> f x)
|
||||
let to_list s = PolyHMap.fold (fun x () l -> x :: l) s []
|
||||
end
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
|
||||
(** Imperative sets of hashed values. *)
|
||||
module HashSet : sig
|
||||
type 'a t
|
||||
|
||||
val create : int -> 'a t
|
||||
val add : 'a t -> 'a -> unit
|
||||
val remove : 'a t -> 'a -> unit
|
||||
|
||||
val cardinal : 'a t -> int
|
||||
val mem : 'a t -> 'a -> bool
|
||||
|
||||
val iter : ('a -> unit) -> 'a t -> unit
|
||||
val exists : ('a -> bool) -> 'a t -> bool
|
||||
val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val to_list : 'a t -> 'a list
|
||||
end
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
module Hashtbl = struct
|
||||
type ('a,'b) t = ('a,'b) Hashtbl.t
|
||||
|
||||
let hash = Hashtbl.hash
|
||||
let hash_param = Hashtbl.hash_param
|
||||
|
||||
let create n = Hashtbl.create n
|
||||
let clear = Hashtbl.clear
|
||||
let copy = Hashtbl.copy
|
||||
let add = Hashtbl.add
|
||||
let replace = Hashtbl.replace
|
||||
let remove = Hashtbl.remove
|
||||
|
||||
let length = Hashtbl.length
|
||||
let mem = Hashtbl.mem
|
||||
let find = Hashtbl.find
|
||||
let find_all = Hashtbl.find_all
|
||||
|
||||
let iter = Hashtbl.iter
|
||||
let fold = Hashtbl.fold
|
||||
|
||||
exception Found_is_empty
|
||||
let is_empty t =
|
||||
try iter (fun _ -> raise Found_is_empty) t ; true with Found_is_empty -> false
|
||||
|
||||
let tryfind t x = try Some(find t x) with Not_found -> None
|
||||
|
||||
exception Found_exists
|
||||
let exists p t =
|
||||
try iter (fun k v -> if p k v then raise Found_exists) t ; false
|
||||
with Found_exists -> true
|
||||
|
||||
let existsi k p t = List.exists p (find_all t k)
|
||||
|
||||
let to_list t = fold (fun k v es -> (k,v) :: es) t []
|
||||
|
||||
let filter p t =
|
||||
List.iter (fun (k,v) -> if not (p k v) then remove t k) (to_list t)
|
||||
|
||||
let map f t =
|
||||
let t' = create (length t) in
|
||||
iter (fun k v -> add t' k (f v) ) t ;
|
||||
t'
|
||||
|
||||
let mapi f t =
|
||||
let t' = create (length t) in
|
||||
iter (fun k v -> add t' k (f k v) ) t ;
|
||||
t'
|
||||
|
||||
module Make(H: HashedType) = struct
|
||||
include Hashtbl.Make(H)
|
||||
|
||||
let is_empty t =
|
||||
try iter (fun _ -> raise Found_is_empty) t ; true with Found_is_empty -> false
|
||||
|
||||
let tryfind t x = try Some(find t x) with Not_found -> None
|
||||
|
||||
let exists p t =
|
||||
try iter (fun k v -> if p k v then raise Found_exists) t ; false
|
||||
with Found_exists -> true
|
||||
|
||||
let existsi k p t = List.exists p (find_all t k)
|
||||
|
||||
let to_list t = fold (fun k v es -> (k,v) :: es) t []
|
||||
|
||||
let filter p t =
|
||||
List.iter (fun (k,v) -> if not (p k v) then remove t k) (to_list t)
|
||||
|
||||
let map f t =
|
||||
let t' = create (length t) in
|
||||
iter (fun k v -> add t' k (f v) ) t ;
|
||||
t'
|
||||
|
||||
let mapi f t =
|
||||
let t' = create (length t) in
|
||||
iter (fun k v -> add t' k (f k v) ) t ;
|
||||
t'
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
|
||||
(** @deprecated Make the standard [Hashtbl] read-only since it confuses maps
|
||||
and multi-maps. Use [HashMap] or [HashMultiMap] instead. *)
|
||||
module Hashtbl : sig
|
||||
type ('a, 'b) t = ('a, 'b) Hashtbl.t
|
||||
val hash : 'a -> int
|
||||
val hash_param : int -> int -> 'a -> int
|
||||
val create : int -> ('a, 'b) Hashtbl.t
|
||||
val clear : ('a, 'b) Hashtbl.t -> unit
|
||||
val copy : ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t
|
||||
val add : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit
|
||||
val replace : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit
|
||||
val remove : ('a, 'b) Hashtbl.t -> 'a -> unit
|
||||
val length : ('a, 'b) Hashtbl.t -> int
|
||||
val mem : ('a, 'b) Hashtbl.t -> 'a -> bool
|
||||
val find : ('a, 'b) Hashtbl.t -> 'a -> 'b
|
||||
val find_all : ('a, 'b) Hashtbl.t -> 'a -> 'b list
|
||||
val iter : ('a -> 'b -> unit) -> ('a, 'b) Hashtbl.t -> unit
|
||||
val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) Hashtbl.t -> 'c -> 'c
|
||||
val is_empty : ('a, 'b) Hashtbl.t -> bool
|
||||
val tryfind : ('a, 'b) Hashtbl.t -> 'a -> 'b option
|
||||
val exists : ('a -> 'b -> bool) -> ('a, 'b) Hashtbl.t -> bool
|
||||
val existsi : 'a -> ('b -> bool) -> ('a, 'b) Hashtbl.t -> bool
|
||||
val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list
|
||||
val filter : ('a -> 'b -> bool) -> ('a, 'b) Hashtbl.t -> unit
|
||||
val map : ('v -> 'w) -> ('k, 'v) Hashtbl.t -> ('k, 'w) Hashtbl.t
|
||||
val mapi : ('k -> 'v -> 'w) -> ('k, 'v) Hashtbl.t -> ('k, 'w) Hashtbl.t
|
||||
module Make(H : NSLib.HashedType) : sig
|
||||
type key = H.t
|
||||
type 'a t = 'a Hashtbl.Make(H).t
|
||||
val create : int -> 'a t
|
||||
val clear : 'a t -> unit
|
||||
val copy : 'a t -> 'a t
|
||||
val add : 'a t -> key -> 'a -> unit
|
||||
val remove : 'a t -> key -> unit
|
||||
val find : 'a t -> key -> 'a
|
||||
val find_all : 'a t -> key -> 'a list
|
||||
val replace : 'a t -> key -> 'a -> unit
|
||||
val mem : 'a t -> key -> bool
|
||||
val iter : (key -> 'a -> unit) -> 'a t -> unit
|
||||
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val length : 'a t -> int
|
||||
val is_empty : 'a t -> bool
|
||||
val tryfind : 'a t -> key -> 'a option
|
||||
val exists : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val existsi : key -> ('a -> bool) -> 'a t -> bool
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
val filter : (key -> 'a -> bool) -> 'a t -> unit
|
||||
val map : ('v -> 'w) -> 'v t -> 'w t
|
||||
val mapi : (key -> 'v -> 'w) -> 'v t -> 'w t
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSMap
|
||||
|
||||
|
||||
module ImperativeMap = struct
|
||||
module type S = sig
|
||||
type key
|
||||
type 'a t
|
||||
|
||||
val create : unit -> 'a t
|
||||
val clear : 'a t -> unit
|
||||
val copy : 'a t -> 'a t
|
||||
val add : 'a t -> key -> 'a -> unit
|
||||
val remove : 'a t -> key -> unit
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
val length : 'a t -> int
|
||||
val mem : 'a t -> key -> bool
|
||||
val find : 'a t -> key -> 'a
|
||||
val tryfind : 'a t -> key -> 'a option
|
||||
|
||||
val iter : (key -> 'a -> unit) -> 'a t -> unit
|
||||
val exists : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val filter : (key -> 'a -> bool) -> 'a t -> unit
|
||||
val map : ('a -> 'a) -> 'a t -> unit
|
||||
val mapi : (key -> 'a -> 'a) -> 'a t -> unit
|
||||
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
end
|
||||
|
||||
module Make(Key: OrderedType) = struct
|
||||
module M = Map.Make(Key)
|
||||
type key = Key.t
|
||||
type 'a t = 'a M.t ref
|
||||
|
||||
let create () = ref M.empty
|
||||
let clear t = t := M.empty
|
||||
let copy t = ref !t
|
||||
let add t k v = t := M.add k v !t
|
||||
let remove t k = t := M.remove k !t
|
||||
|
||||
let is_empty t = M.is_empty !t
|
||||
let length t = M.cardinal !t
|
||||
let mem t k = M.mem k !t
|
||||
let find t k = M.find k !t
|
||||
let tryfind t k = M.tryfind k !t
|
||||
|
||||
let iter f t = M.iter f !t
|
||||
let exists f t = M.exists f !t
|
||||
let filter f t = t := M.filter f !t
|
||||
let map f t = t := M.map f !t
|
||||
let mapi f t = t := M.mapi f !t
|
||||
let fold f t a = M.fold f !t a
|
||||
let to_list t = M.to_list !t
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
module IntIMap = ImperativeMap.Make(struct
|
||||
type t = int
|
||||
let compare = (Pervasives.compare : int -> int -> int)
|
||||
let equal = (Pervasives.( = ) : int -> int -> bool)
|
||||
end)
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Imperative maps from ordered keys to single values. *)
|
||||
module ImperativeMap : sig
|
||||
module type S = sig
|
||||
type key
|
||||
type 'a t
|
||||
|
||||
val create : unit -> 'a t
|
||||
val clear : 'a t -> unit
|
||||
val copy : 'a t -> 'a t
|
||||
val add : 'a t -> key -> 'a -> unit
|
||||
val remove : 'a t -> key -> unit
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
val length : 'a t -> int
|
||||
val mem : 'a t -> key -> bool
|
||||
val find : 'a t -> key -> 'a
|
||||
val tryfind : 'a t -> key -> 'a option
|
||||
|
||||
val iter : (key -> 'a -> unit) -> 'a t -> unit
|
||||
val exists : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val filter : (key -> 'a -> bool) -> 'a t -> unit
|
||||
val map : ('a -> 'a) -> 'a t -> unit
|
||||
val mapi : (key -> 'a -> 'a) -> 'a t -> unit
|
||||
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
end
|
||||
|
||||
module Make (Key: OrderedType) : (S with type key = Key.t)
|
||||
end
|
||||
|
||||
|
||||
module IntIMap : ImperativeMap.S with type key = int
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSMultiMap
|
||||
|
||||
|
||||
module ImperativeMultiMap = struct
|
||||
module type S = sig
|
||||
type k
|
||||
type v
|
||||
type vs
|
||||
type t
|
||||
|
||||
val create : unit -> t
|
||||
val clear : t -> unit
|
||||
val copy : t -> t
|
||||
val add : t -> k -> v -> unit
|
||||
val replace : t -> k -> vs -> unit
|
||||
val remove : t -> k -> unit
|
||||
|
||||
val is_empty : t -> bool
|
||||
val length : t -> int
|
||||
val mem : t -> k -> bool
|
||||
val find : t -> k -> vs
|
||||
|
||||
val iter : (k -> v -> unit) -> t -> unit
|
||||
val iter_keys : (k -> vs -> unit) -> t -> unit
|
||||
val exists : (k -> v -> bool) -> t -> bool
|
||||
val existsi : k -> (v -> bool) -> t -> bool
|
||||
val filter : (k -> v -> bool) -> t -> unit
|
||||
val filteri : k -> (v -> bool) -> t -> unit
|
||||
val map : (v -> v) -> t -> unit
|
||||
val mapi : (k -> v -> v) -> t -> unit
|
||||
val fold : (k -> v -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_keys : (k -> vs -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val to_list : t -> (k * v) list
|
||||
end
|
||||
|
||||
module Make (Key: OrderedType) (ValSet: Set0) = struct
|
||||
module M = MultiMap.Make(Key)(ValSet)
|
||||
type k = M.k
|
||||
type v = M.v
|
||||
type vs = M.vs
|
||||
type t = M.t ref
|
||||
|
||||
let create () = ref M.empty
|
||||
let clear t = t := M.empty
|
||||
let copy t = ref !t
|
||||
let add t k v = t := M.add k v !t
|
||||
let replace t k vs = t := M.replace k vs !t
|
||||
let remove t k = t := M.remove k !t
|
||||
|
||||
let is_empty t = M.is_empty !t
|
||||
let length t = M.length !t
|
||||
let mem t k = M.mem k !t
|
||||
let find t k = M.find k !t
|
||||
|
||||
let iter f t = M.iter f !t
|
||||
let iter_keys f t = M.iter_keys f !t
|
||||
let exists p t = M.exists p !t
|
||||
let existsi k p t = M.existsi k p !t
|
||||
let filter p t = t := M.filter p !t
|
||||
let filteri k p t = t := M.filteri k p !t
|
||||
let map f t = t := M.map f !t
|
||||
let mapi f t = t := M.mapi f !t
|
||||
let fold f t = M.fold f !t
|
||||
let fold_keys f t = M.fold_keys f !t
|
||||
let to_list t = M.to_list !t
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Imperative maps from ordered keys to multiple values. *)
|
||||
module ImperativeMultiMap : sig
|
||||
module type S = sig
|
||||
type k
|
||||
type v
|
||||
type vs
|
||||
type t
|
||||
|
||||
val create : unit -> t
|
||||
val clear : t -> unit
|
||||
val copy : t -> t
|
||||
val add : t -> k -> v -> unit
|
||||
val replace : t -> k -> vs -> unit
|
||||
val remove : t -> k -> unit
|
||||
|
||||
val is_empty : t -> bool
|
||||
val length : t -> int
|
||||
val mem : t -> k -> bool
|
||||
val find : t -> k -> vs
|
||||
|
||||
val iter : (k -> v -> unit) -> t -> unit
|
||||
val iter_keys : (k -> vs -> unit) -> t -> unit
|
||||
val exists : (k -> v -> bool) -> t -> bool
|
||||
val existsi : k -> (v -> bool) -> t -> bool
|
||||
val filter : (k -> v -> bool) -> t -> unit
|
||||
val filteri : k -> (v -> bool) -> t -> unit
|
||||
val map : (v -> v) -> t -> unit
|
||||
val mapi : (k -> v -> v) -> t -> unit
|
||||
val fold : (k -> v -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_keys : (k -> vs -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val to_list : t -> (k * v) list
|
||||
end
|
||||
|
||||
module Make(Key: OrderedType)(ValSet: Set0) :
|
||||
(S with type k = Key.t and type v = ValSet.elt and type vs = ValSet.t)
|
||||
end
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSList
|
||||
open NSImperativeMap
|
||||
|
||||
|
||||
module ImperativeSet = struct
|
||||
module type S = sig
|
||||
type v
|
||||
type t
|
||||
|
||||
val create : unit -> t
|
||||
val clear : t -> unit
|
||||
val copy : t -> t
|
||||
val add : t -> v -> unit
|
||||
val remove : t -> v -> unit
|
||||
|
||||
val is_empty : t -> bool
|
||||
val mem : t -> v -> bool
|
||||
|
||||
val iter : (v -> unit) -> t -> unit
|
||||
val exists : (v -> bool) -> t -> bool
|
||||
val fold : (v -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val to_list : t -> v list
|
||||
end
|
||||
|
||||
module Make(Val: OrderedType) = struct
|
||||
module M = ImperativeMap.Make(Val)
|
||||
|
||||
type v = Val.t
|
||||
type t = unit M.t
|
||||
|
||||
let create = M.create
|
||||
let clear = M.clear
|
||||
let copy = M.copy
|
||||
let add s x = M.add s x ()
|
||||
let remove = M.remove
|
||||
|
||||
let is_empty = M.is_empty
|
||||
let mem = M.mem
|
||||
|
||||
let iter f = M.iter (fun x () -> f x)
|
||||
let exists p = M.exists (fun x () -> p x)
|
||||
let fold f = M.fold (fun x () -> f x)
|
||||
let to_list s = fold List.cons s []
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Imperative sets of ordered values. *)
|
||||
module ImperativeSet : sig
|
||||
module type S = sig
|
||||
type v
|
||||
type t
|
||||
|
||||
val create : unit -> t
|
||||
val clear : t -> unit
|
||||
val copy : t -> t
|
||||
val add : t -> v -> unit
|
||||
val remove : t -> v -> unit
|
||||
|
||||
val is_empty : t -> bool
|
||||
val mem : t -> v -> bool
|
||||
|
||||
val iter : (v -> unit) -> t -> unit
|
||||
val exists : (v -> bool) -> t -> bool
|
||||
val fold : (v -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val to_list : t -> v list
|
||||
end
|
||||
|
||||
module Make (Val : OrderedType) : (S with type v = Val.t)
|
||||
end
|
||||
|
|
@ -0,0 +1,229 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSList
|
||||
open NSSet
|
||||
open NSMap
|
||||
|
||||
|
||||
module type IndexedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
type idx
|
||||
val index : t -> idx
|
||||
val equal_idx : idx -> idx -> bool
|
||||
val compare_idx : idx -> idx -> int
|
||||
end
|
||||
|
||||
(** Sets of [IndexedType]s, where an [indexedType] is an [OrderedType] where
|
||||
each value [v] is associated with an index [index v]. The indices of all
|
||||
values in an [IndexedSet] are required to be disjoint. *)
|
||||
module IndexedSet = struct
|
||||
module type S = sig
|
||||
include Set.S
|
||||
type idx
|
||||
val memi : idx -> t -> bool
|
||||
val find : idx -> t -> elt
|
||||
val tryfind : idx -> t -> elt option
|
||||
val keys : t -> idx list
|
||||
val fold_keys : (idx -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
end
|
||||
|
||||
module Make(Val: IndexedType) = struct
|
||||
|
||||
module Key = struct
|
||||
type t = Val.idx
|
||||
let equal = Val.equal_idx
|
||||
let compare = Val.compare_idx
|
||||
end
|
||||
|
||||
module M = Map.Make(Key)
|
||||
|
||||
type elt = Val.t
|
||||
type t = Val.t M.t
|
||||
|
||||
|
||||
(* constructors *)
|
||||
|
||||
let empty = M.empty
|
||||
|
||||
let add v m =
|
||||
assert(
|
||||
(try Val.equal v (M.find (Val.index v) m) with Not_found -> true)
|
||||
|| invalid_arg "IndexedSet: indices must be disjoint"
|
||||
);
|
||||
M.add (Val.index v) v m
|
||||
|
||||
let adds l m = List.fold add l m
|
||||
|
||||
let singleton v = add v empty
|
||||
|
||||
let of_list vl = List.fold add vl empty
|
||||
|
||||
let remove v s =
|
||||
let i = Val.index v in
|
||||
try if Val.equal v (M.find i s) then M.remove i s else s
|
||||
with Not_found -> s
|
||||
|
||||
let union m n =
|
||||
M.merge (fun _ vo0 vo1 ->
|
||||
match vo0, vo1 with
|
||||
| None , None -> None
|
||||
| Some _ , None -> vo0
|
||||
| None , Some _ -> vo1
|
||||
| Some(v0), Some(v1) -> vo0
|
||||
$> assert(
|
||||
Val.equal v0 v1
|
||||
|| invalid_arg "IndexedSet: indices must be disjoint"
|
||||
)
|
||||
) m n
|
||||
|
||||
let unions = function
|
||||
| [] -> empty
|
||||
| m :: [] -> m
|
||||
| m :: ml -> List.fold union ml m
|
||||
|
||||
let inter m n =
|
||||
M.merge (fun _ vo0 vo1 ->
|
||||
match vo0, vo1 with
|
||||
| None , _ -> None
|
||||
| _ , None -> None
|
||||
| Some(v0), Some(v1) -> vo0
|
||||
$> assert(
|
||||
Val.equal v0 v1
|
||||
|| invalid_arg "IndexedSet: indices must be disjoint"
|
||||
)
|
||||
) m n
|
||||
|
||||
let inters = function
|
||||
| [] -> invalid_arg "IndexedSet.inters: must be non-nil"
|
||||
| m :: [] -> m
|
||||
| m :: ml -> List.fold inter ml m
|
||||
|
||||
let diff m n =
|
||||
M.merge (fun _ vo0 vo1 ->
|
||||
match vo0, vo1 with
|
||||
| None , _ -> None
|
||||
| _ , None -> vo0
|
||||
| Some(v0), Some(v1) -> None
|
||||
$> assert(
|
||||
Val.equal v0 v1
|
||||
|| invalid_arg "IndexedSet: indices must be disjoint"
|
||||
)
|
||||
) m n
|
||||
|
||||
let fold f m z = M.fold (fun _ v z -> f v z) m z
|
||||
|
||||
let fold_keys f m z = M.fold f m z
|
||||
|
||||
let mem v s =
|
||||
try Val.equal v (M.find (Val.index v) s)
|
||||
with Not_found -> false
|
||||
|
||||
let diff_inter_diff s t =
|
||||
fold (fun a ((s_m_i, i, t_m_i) as acc) ->
|
||||
if mem a t
|
||||
then (remove a s_m_i, add a i, remove a t_m_i)
|
||||
else acc
|
||||
) s (s, empty, t)
|
||||
|
||||
let diff_diff s t =
|
||||
let s_m_i, _, t_m_i = diff_inter_diff s t in
|
||||
(s_m_i, t_m_i)
|
||||
|
||||
let inter_diff s t =
|
||||
let _, i, t_m_i = diff_inter_diff s t in
|
||||
(i, t_m_i)
|
||||
|
||||
let map fn s = fold (fun kv t -> add (fn kv) t) s empty
|
||||
|
||||
let map_fold _ = failwith "ToDo: IndexedSet.map_fold"
|
||||
let map_foldi _ = failwith "ToDo: IndexedSet.map_foldi"
|
||||
|
||||
let filter p m = M.filter (fun _ v -> p v) m
|
||||
|
||||
let partition p m = M.partition (fun _ v -> p v) m
|
||||
|
||||
let split v m =
|
||||
let lt, eq, gt = M.split (Val.index v) m in
|
||||
(lt, eq <> None, gt)
|
||||
|
||||
(* queries / destructors *)
|
||||
|
||||
let is_empty = M.is_empty
|
||||
|
||||
let compare m n = M.compare Val.compare m n
|
||||
|
||||
let equal m n = M.equal Val.equal m n
|
||||
|
||||
let subset m n = is_empty (diff m n)
|
||||
|
||||
let disjoint _ = failwith "ToDo: IndexedSet.disjoint"
|
||||
let intersect _ = failwith "ToDo: IndexedSet.intersect"
|
||||
|
||||
let iter f m = M.iter (fun _ v -> f v) m
|
||||
|
||||
let foldr _ = failwith "ToDo: IndexedSet.foldr"
|
||||
let foldi _ = failwith "ToDo: IndexedSet.foldi"
|
||||
let fold_pairs _ = failwith "ToDo: IndexedSet.fold_pairs"
|
||||
|
||||
let fold_product fn xs ys =
|
||||
fold (fun x -> fold (fun y -> fn x y) ys) xs
|
||||
|
||||
let fold2 _ = failwith "ToDo: IndexedSet.fold2"
|
||||
|
||||
let to_list m = M.fold (fun _ v z -> v :: z) m []
|
||||
|
||||
let kfold x fn k = List.kfold fn (to_list x) k
|
||||
|
||||
let for_all p m = M.for_all (fun _ v -> p v) m
|
||||
|
||||
let exists p m = M.exists (fun _ v -> p v) m
|
||||
|
||||
let exists_unique p m = M.exists_unique (fun _ v -> p v) m
|
||||
|
||||
let cardinal m = M.cardinal m
|
||||
|
||||
let to_array _ = failwith "ToDo: IndexedSet.to_array"
|
||||
|
||||
let keys m = M.fold (fun i _ z -> i :: z) m []
|
||||
|
||||
let min_elt m = snd (M.min_binding m)
|
||||
|
||||
let max_elt m = snd (M.max_binding m)
|
||||
|
||||
let next _ = failwith "ToDo: IndexedSet.next"
|
||||
|
||||
let choose m = snd (M.choose m)
|
||||
|
||||
exception Found of elt
|
||||
let trychoose s =
|
||||
try iter (fun kv -> raise (Found(kv))) s ; None
|
||||
with Found(kv) -> Some(kv)
|
||||
|
||||
let extract _ = failwith "ToDo: NSIndexedSet.Lift.extract"
|
||||
let tryextract _ = failwith "ToDo: NSIndexedSet.Lift.tryextract"
|
||||
|
||||
let take _ _ = failwith "ToDo: IndexedSet.take"
|
||||
|
||||
let trytake p s =
|
||||
try Some(take p s) with Not_found -> None
|
||||
|
||||
let take_first_pair _ = failwith "ToDo: IndexedSet.take_first_pair"
|
||||
let the_only _ = failwith "ToDo: IndexedSet.the_only"
|
||||
|
||||
type idx = Val.idx
|
||||
|
||||
let find i m = M.find i m
|
||||
|
||||
let tryfind i m = M.tryfind i m
|
||||
|
||||
let memi i m = M.mem i m
|
||||
|
||||
let reduce _ = failwith "ToDo: NSIndexedSet.Lift.reduce"
|
||||
|
||||
let classify _ = failwith "ToDo: NSIndexedSet.Lift.classify"
|
||||
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSSet
|
||||
|
||||
|
||||
module type IndexedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
type idx
|
||||
val index : t -> idx
|
||||
val equal_idx : idx -> idx -> bool
|
||||
val compare_idx : idx -> idx -> int
|
||||
end
|
||||
|
||||
module IndexedSet : sig
|
||||
module type S = sig
|
||||
include Set.S
|
||||
type idx
|
||||
val memi : idx -> t -> bool
|
||||
val find : idx -> t -> elt
|
||||
val tryfind : idx -> t -> elt option
|
||||
val keys : t -> idx list
|
||||
val fold_keys : (idx -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
end
|
||||
|
||||
module Make(Idx: IndexedType) :
|
||||
(S with type elt = Idx.t and type idx = Idx.idx)
|
||||
end
|
||||
|
|
@ -0,0 +1,270 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(* Non-Standard Library *)
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Combinators
|
||||
============================================================================*)
|
||||
|
||||
(* Function combinators *)
|
||||
|
||||
let id x = x
|
||||
let const f _ = f
|
||||
let flip f x y = f y x
|
||||
let curry f x y = f (x,y)
|
||||
let uncurry f (x,y) = f x y
|
||||
|
||||
let ( &> ) x f = f x ; x
|
||||
let ( <& ) f x = f x ; x
|
||||
let ( $> ) x y = y; x
|
||||
|
||||
|
||||
(* Tuple combinators *)
|
||||
|
||||
let pair x y = (x,y)
|
||||
let swap (x,y) = (y,x)
|
||||
let fst3 (x,_,_) = x
|
||||
let snd3 (_,y,_) = y
|
||||
let thd3 (_,_,z) = z
|
||||
let fst4 (w,_,_,_) = w
|
||||
let snd4 (_,x,_,_) = x
|
||||
let thd4 (_,_,y,_) = y
|
||||
let fth4 (_,_,_,z) = z
|
||||
|
||||
let ( *** ) f g (x,y) = (f x, g y)
|
||||
|
||||
|
||||
(* Predicate combinators *)
|
||||
|
||||
let ( &&& ) p q x = p x && q x
|
||||
let ( ||| ) p q x = p x || q x
|
||||
|
||||
|
||||
(* Equality combinators *)
|
||||
|
||||
let equal_tup2 equal0 equal1 (x0,x1) (y0,y1) = equal0 x0 y0 && equal1 x1 y1
|
||||
|
||||
let equal_tup3 equal0 equal1 equal2 (x0,x1,x2) (y0,y1,y2) = equal0 x0 y0 && equal1 x1 y1 && equal2 x2 y2
|
||||
|
||||
let equal_tup4 equal0 equal1 equal2 equal3 (x0,x1,x2,x3) (y0,y1,y2,y3) = equal0 x0 y0 && equal1 x1 y1 && equal2 x2 y2 && equal3 x3 y3
|
||||
|
||||
let equal_tup5 equal0 equal1 equal2 equal3 equal4 (x0,x1,x2,x3,x4) (y0,y1,y2,y3,y4) =
|
||||
equal0 x0 y0 && equal1 x1 y1 && equal2 x2 y2 && equal3 x3 y3 && equal4 x4 y4
|
||||
|
||||
let equal_tup6 equal0 equal1 equal2 equal3 equal4 equal5 (x0,x1,x2,x3,x4,x5) (y0,y1,y2,y3,y4,y5) =
|
||||
equal0 x0 y0 && equal1 x1 y1 && equal2 x2 y2 && equal3 x3 y3 && equal4 x4 y4 && equal5 x5 y5
|
||||
|
||||
let equal_tup7 equal0 equal1 equal2 equal3 equal4 equal5 equal6 (x0,x1,x2,x3,x4,x5,x6) (y0,y1,y2,y3,y4,y5,y6) =
|
||||
equal0 x0 y0 && equal1 x1 y1 && equal2 x2 y2 && equal3 x3 y3 && equal4 x4 y4 && equal5 x5 y5 && equal6 x6 y6
|
||||
|
||||
let equal_tup8 equal0 equal1 equal2 equal3 equal4 equal5 equal6 equal7 (x0,x1,x2,x3,x4,x5,x6,x7) (y0,y1,y2,y3,y4,y5,y6,y7) =
|
||||
equal0 x0 y0 && equal1 x1 y1 && equal2 x2 y2 && equal3 x3 y3 && equal4 x4 y4 && equal5 x5 y5 && equal6 x6 y6 && equal7 x7 y7
|
||||
|
||||
let equal_tup9 equal0 equal1 equal2 equal3 equal4 equal5 equal6 equal7 equal8 (x0,x1,x2,x3,x4,x5,x6,x7,x8) (y0,y1,y2,y3,y4,y5,y6,y7,y8) =
|
||||
equal0 x0 y0 && equal1 x1 y1 && equal2 x2 y2 && equal3 x3 y3 && equal4 x4 y4 && equal5 x5 y5 && equal6 x6 y6 && equal7 x7 y7 && equal8 x8 y8
|
||||
|
||||
|
||||
(* Comparison combinators *)
|
||||
|
||||
let compare_tup2 compare0 compare1 (x0,x1) (y0,y1) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else compare1 x1 y1
|
||||
|
||||
let compare_tup3 compare0 compare1 compare2 (x0,x1,x2) (y0,y1,y2) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else
|
||||
let ord = compare1 x1 y1 in if ord <> 0 then ord else
|
||||
compare2 x2 y2
|
||||
|
||||
let compare_tup4 compare0 compare1 compare2 compare3 (x0,x1,x2,x3) (y0,y1,y2,y3) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else
|
||||
let ord = compare1 x1 y1 in if ord <> 0 then ord else
|
||||
let ord = compare2 x2 y2 in if ord <> 0 then ord else
|
||||
compare3 x3 y3
|
||||
|
||||
let compare_tup5 compare0 compare1 compare2 compare3 compare4 (x0,x1,x2,x3,x4) (y0,y1,y2,y3,y4) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else
|
||||
let ord = compare1 x1 y1 in if ord <> 0 then ord else
|
||||
let ord = compare2 x2 y2 in if ord <> 0 then ord else
|
||||
let ord = compare3 x3 y3 in if ord <> 0 then ord else
|
||||
compare4 x4 y4
|
||||
|
||||
let compare_tup6 compare0 compare1 compare2 compare3 compare4 compare5 (x0,x1,x2,x3,x4,x5) (y0,y1,y2,y3,y4,y5) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else
|
||||
let ord = compare1 x1 y1 in if ord <> 0 then ord else
|
||||
let ord = compare2 x2 y2 in if ord <> 0 then ord else
|
||||
let ord = compare3 x3 y3 in if ord <> 0 then ord else
|
||||
let ord = compare4 x4 y4 in if ord <> 0 then ord else
|
||||
compare5 x5 y5
|
||||
|
||||
let compare_tup7 compare0 compare1 compare2 compare3 compare4 compare5 compare6 (x0,x1,x2,x3,x4,x5,x6) (y0,y1,y2,y3,y4,y5,y6) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else
|
||||
let ord = compare1 x1 y1 in if ord <> 0 then ord else
|
||||
let ord = compare2 x2 y2 in if ord <> 0 then ord else
|
||||
let ord = compare3 x3 y3 in if ord <> 0 then ord else
|
||||
let ord = compare4 x4 y4 in if ord <> 0 then ord else
|
||||
let ord = compare5 x5 y5 in if ord <> 0 then ord else
|
||||
compare6 x6 y6
|
||||
|
||||
let compare_tup8 compare0 compare1 compare2 compare3 compare4 compare5 compare6 compare7 (x0,x1,x2,x3,x4,x5,x6,x7) (y0,y1,y2,y3,y4,y5,y6,y7) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else
|
||||
let ord = compare1 x1 y1 in if ord <> 0 then ord else
|
||||
let ord = compare2 x2 y2 in if ord <> 0 then ord else
|
||||
let ord = compare3 x3 y3 in if ord <> 0 then ord else
|
||||
let ord = compare4 x4 y4 in if ord <> 0 then ord else
|
||||
let ord = compare5 x5 y5 in if ord <> 0 then ord else
|
||||
let ord = compare6 x6 y6 in if ord <> 0 then ord else
|
||||
compare7 x7 y7
|
||||
|
||||
let compare_tup9 compare0 compare1 compare2 compare3 compare4 compare5 compare6 compare7 compare8 (x0,x1,x2,x3,x4,x5,x6,x7,x8) (y0,y1,y2,y3,y4,y5,y6,y7,y8) =
|
||||
let ord = compare0 x0 y0 in if ord <> 0 then ord else
|
||||
let ord = compare1 x1 y1 in if ord <> 0 then ord else
|
||||
let ord = compare2 x2 y2 in if ord <> 0 then ord else
|
||||
let ord = compare3 x3 y3 in if ord <> 0 then ord else
|
||||
let ord = compare4 x4 y4 in if ord <> 0 then ord else
|
||||
let ord = compare5 x5 y5 in if ord <> 0 then ord else
|
||||
let ord = compare6 x6 y6 in if ord <> 0 then ord else
|
||||
let ord = compare7 x7 y7 in if ord <> 0 then ord else
|
||||
compare8 x8 y8
|
||||
|
||||
|
||||
(* File handling *)
|
||||
|
||||
let with_in_bin filename fn =
|
||||
let chan = open_in_bin filename in
|
||||
let res = fn chan in
|
||||
close_in chan ;
|
||||
res
|
||||
|
||||
let with_out_bin filename fn arg =
|
||||
let chan = open_out_bin filename in
|
||||
let res = fn chan arg in
|
||||
close_out chan ;
|
||||
res
|
||||
|
||||
let with_out filename outputter =
|
||||
let buf = Buffer.create 128 in
|
||||
let res = outputter buf in
|
||||
let chan = open_out filename in
|
||||
Buffer.output_buffer chan buf ;
|
||||
close_out chan ;
|
||||
res
|
||||
|
||||
|
||||
(* Formatting *)
|
||||
|
||||
type 'a formatter = Format.formatter -> 'a -> unit
|
||||
type 'a format_str = ('a formatter -> 'a -> unit, Format.formatter, unit) format
|
||||
|
||||
let ifbreakf fmt ff =
|
||||
Format.pp_print_if_newline ff () ;
|
||||
Format.fprintf ff fmt
|
||||
|
||||
let failwithf fmt =
|
||||
Format.kfprintf (fun _ -> failwith (Format.flush_str_formatter ()))
|
||||
Format.str_formatter ("@\n@["^^fmt^^"@]@\n")
|
||||
|
||||
let invalid_argf fmt =
|
||||
Format.kfprintf (fun _ -> invalid_arg (Format.flush_str_formatter ()))
|
||||
Format.str_formatter ("@\n@["^^fmt^^"@]@\n")
|
||||
|
||||
exception Nothing_to_fmt
|
||||
|
||||
|
||||
(* Exception handling *)
|
||||
|
||||
exception Undef
|
||||
|
||||
let try_finally f g =
|
||||
let res =
|
||||
try
|
||||
f ()
|
||||
with e ->
|
||||
g () ;
|
||||
raise e
|
||||
in
|
||||
g () ;
|
||||
res
|
||||
|
||||
let finally_try g f =
|
||||
let res =
|
||||
try
|
||||
f ()
|
||||
with e ->
|
||||
prerr_endline (Printexc.to_string e) ;
|
||||
g () ;
|
||||
raise e
|
||||
in
|
||||
g () ;
|
||||
res
|
||||
|
||||
let debug_wrap1 verbose shift fn z =
|
||||
try fn z with _ -> verbose := !verbose + shift ; fn z
|
||||
|
||||
let debug_wrap2 verbose shift fn y z =
|
||||
try fn y z with _ -> verbose := !verbose + shift ; fn y z
|
||||
|
||||
let debug_wrap3 verbose shift fn x y z =
|
||||
try fn x y z with _ -> verbose := !verbose + shift ; fn x y z
|
||||
|
||||
let debug_wrap4 verbose shift fn w x y z =
|
||||
try fn w x y z with _ -> verbose := !verbose + shift ; fn w x y z
|
||||
|
||||
let debug_wrap5 verbose shift fn v w x y z =
|
||||
try fn v w x y z with _ -> verbose := !verbose + shift ; fn v w x y z
|
||||
|
||||
|
||||
(* Module Types *)
|
||||
|
||||
module type EqualityType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
end
|
||||
|
||||
module type OrderedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
end
|
||||
|
||||
module type HashedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val hash: t -> int
|
||||
end
|
||||
|
||||
module HashedTypeTup2 (H0: HashedType) (H1: HashedType) = struct
|
||||
type t = H0.t * H1.t
|
||||
let equal = equal_tup2 H0.equal H1.equal
|
||||
let hash (x,y) = Hashtbl.hash (H0.hash x, H1.hash y)
|
||||
end
|
||||
|
||||
module type Set0 = sig
|
||||
type elt
|
||||
type t
|
||||
val empty : t
|
||||
val is_empty : t -> bool
|
||||
val add : elt -> t -> t
|
||||
val singleton : elt -> t
|
||||
val iter : (elt -> unit) -> t -> unit
|
||||
val map : (elt -> elt) -> t -> t
|
||||
val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val map_fold : (elt * 'z -> elt * 'z) -> t * 'z -> t * 'z
|
||||
val kfold : t -> (elt -> ('a->'b) -> 'a->'b) -> ('a->'b) -> 'a->'b
|
||||
val for_all : (elt -> bool) -> t -> bool
|
||||
val exists : (elt -> bool) -> t -> bool
|
||||
val exists_unique : (elt -> bool) -> t -> bool
|
||||
val filter : (elt -> bool) -> t -> t
|
||||
val cardinal : t -> int
|
||||
val of_list : elt list -> t
|
||||
val to_list : t -> elt list
|
||||
val choose : t -> elt
|
||||
val union : t -> t -> t
|
||||
val diff : t -> t -> t
|
||||
end
|
||||
|
||||
module type Set1 = sig
|
||||
include Set0
|
||||
include OrderedType with type t := t
|
||||
val remove : elt -> t -> t
|
||||
val diff_inter_diff : t -> t -> t * t * t
|
||||
end
|
||||
|
|
@ -0,0 +1,186 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
(** Extensions of the standard library. *)
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Combinators
|
||||
============================================================================*)
|
||||
|
||||
(** {3 Combinators } *)
|
||||
|
||||
|
||||
(** {4 Function combinators } *)
|
||||
|
||||
val id : 'a -> 'a
|
||||
val const : 'a -> 'b -> 'a
|
||||
val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
|
||||
val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
|
||||
val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c
|
||||
|
||||
val ( &> ) : 'a -> ('a -> unit) -> 'a
|
||||
(** [x &> f] applies [f] to [x] and returns [x], left associative. *)
|
||||
|
||||
val ( <& ) : ('a -> unit) -> 'a -> 'a
|
||||
(** [f <& x] applies [f] to [x] and returns [x], left associative. *)
|
||||
|
||||
val ( $> ) : 'a -> unit -> 'a
|
||||
(** Reverse sequential composition, left associative *)
|
||||
|
||||
|
||||
|
||||
(** {4 Tuple combinators } *)
|
||||
|
||||
val pair : 'a -> 'b -> 'a * 'b
|
||||
val swap : 'a * 'b -> 'b * 'a
|
||||
|
||||
val fst3 : ('a * 'b * 'c) -> 'a
|
||||
val snd3 : ('a * 'b * 'c) -> 'b
|
||||
val thd3 : ('a * 'b * 'c) -> 'c
|
||||
|
||||
val fst4 : ('a * 'b * 'c * 'd) -> 'a
|
||||
val snd4 : ('a * 'b * 'c * 'd) -> 'b
|
||||
val thd4 : ('a * 'b * 'c * 'd) -> 'c
|
||||
val fth4 : ('a * 'b * 'c * 'd) -> 'd
|
||||
|
||||
val ( *** ) : ('a -> 'b) -> ('c -> 'd) -> 'a * 'c -> 'b * 'd
|
||||
|
||||
|
||||
(** {4 Predicate combinators } *)
|
||||
|
||||
val ( &&& ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool
|
||||
(** Short-circuit conjunction lifted to predicates, left associative. *)
|
||||
|
||||
val ( ||| ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool
|
||||
(** Short-circuit disjunction lifted to predicates, left associative. *)
|
||||
|
||||
|
||||
|
||||
(** {4 Equality combinators } *)
|
||||
|
||||
val equal_tup2 : ('a->'b->bool)->('c->'d->bool)->'a*'c->'b*'d->bool
|
||||
val equal_tup3 : ('a->'b->bool)->('c->'d->bool)->('e->'f->bool)->'a*'c*'e->'b*'d*'f->bool
|
||||
val equal_tup4 : ('a->'b->bool)->('c->'d->bool)->('e->'f->bool)->('g->'h->bool)->'a*'c*'e*'g->'b*'d*'f*'h->bool
|
||||
val equal_tup5 : ('a->'b->bool)->('c->'d->bool)->('e->'f->bool)->('g->'h->bool)->('i->'j->bool)->'a*'c*'e*'g*'i->'b*'d*'f*'h*'j->bool
|
||||
val equal_tup6 : ('a->'b->bool)->('c->'d->bool)->('e->'f->bool)->('g->'h->bool)->('i->'j->bool)->('k->'l->bool)->'a*'c*'e*'g*'i*'k->'b*'d*'f*'h*'j*'l->bool
|
||||
val equal_tup7 : ('a->'b->bool)->('c->'d->bool)->('e->'f->bool)->('g->'h->bool)->('i->'j->bool)->('k->'l->bool)->('m->'n->bool)->'a*'c*'e*'g*'i*'k*'m->'b*'d*'f*'h*'j*'l*'n->bool
|
||||
val equal_tup8 : ('a->'b->bool)->('c->'d->bool)->('e->'f->bool)->('g->'h->bool)->('i->'j->bool)->('k->'l->bool)->('m->'n->bool)->('o->'p->bool)->'a*'c*'e*'g*'i*'k*'m*'o->'b*'d*'f*'h*'j*'l*'n*'p->bool
|
||||
val equal_tup9 : ('a->'b->bool)->('c->'d->bool)->('e->'f->bool)->('g->'h->bool)->('i->'j->bool)->('k->'l->bool)->('m->'n->bool)->('o->'p->bool)->('q->'r->bool)->'a*'c*'e*'g*'i*'k*'m*'o*'q->'b*'d*'f*'h*'j*'l*'n*'p*'r->bool
|
||||
|
||||
|
||||
(** {4 Comparison combinators } *)
|
||||
|
||||
val compare_tup2 : ('a->'b->int)->('c->'d->int)->'a*'c->'b*'d->int
|
||||
val compare_tup3 : ('a->'b->int)->('c->'d->int)->('e->'f->int)->'a*'c*'e->'b*'d*'f->int
|
||||
val compare_tup4 : ('a->'b->int)->('c->'d->int)->('e->'f->int)->('g->'h->int)->'a*'c*'e*'g->'b*'d*'f*'h->int
|
||||
val compare_tup5 : ('a->'b->int)->('c->'d->int)->('e->'f->int)->('g->'h->int)->('i->'j->int)->'a*'c*'e*'g*'i->'b*'d*'f*'h*'j->int
|
||||
val compare_tup6 : ('a->'b->int)->('c->'d->int)->('e->'f->int)->('g->'h->int)->('i->'j->int)->('k->'l->int)->'a*'c*'e*'g*'i*'k->'b*'d*'f*'h*'j*'l->int
|
||||
val compare_tup7 : ('a->'b->int)->('c->'d->int)->('e->'f->int)->('g->'h->int)->('i->'j->int)->('k->'l->int)->('m->'n->int)->'a*'c*'e*'g*'i*'k*'m->'b*'d*'f*'h*'j*'l*'n->int
|
||||
val compare_tup8 : ('a->'b->int)->('c->'d->int)->('e->'f->int)->('g->'h->int)->('i->'j->int)->('k->'l->int)->('m->'n->int)->('o->'p->int)->'a*'c*'e*'g*'i*'k*'m*'o->'b*'d*'f*'h*'j*'l*'n*'p->int
|
||||
val compare_tup9 : ('a->'b->int)->('c->'d->int)->('e->'f->int)->('g->'h->int)->('i->'j->int)->('k->'l->int)->('m->'n->int)->('o->'p->int)->('q->'r->int)->'a*'c*'e*'g*'i*'k*'m*'o*'q->'b*'d*'f*'h*'j*'l*'n*'p*'r->int
|
||||
|
||||
|
||||
(** {3 File handling } *)
|
||||
|
||||
val with_in_bin : string -> (in_channel -> 'a) -> 'a
|
||||
val with_out_bin : string -> (out_channel -> 'a -> 'b) -> 'a -> 'b
|
||||
val with_out : string -> (Buffer.t -> 'a) -> 'a
|
||||
|
||||
|
||||
(** {3 Exception handling } *)
|
||||
|
||||
exception Undef
|
||||
|
||||
val try_finally : (unit -> 'a) -> (unit -> 'b) -> 'a
|
||||
val finally_try : (unit -> 'b) -> (unit -> 'a) -> 'a
|
||||
val debug_wrap1 : int ref -> int -> ('a->'b) -> 'a->'b
|
||||
val debug_wrap2 : int ref -> int -> ('a->'b->'c) -> 'a->'b->'c
|
||||
val debug_wrap3 : int ref -> int -> ('a->'b->'c->'d) -> 'a->'b->'c->'d
|
||||
val debug_wrap4 : int ref -> int -> ('a->'b->'c->'d->'e) -> 'a->'b->'c->'d->'e
|
||||
val debug_wrap5 : int ref -> int -> ('a->'b->'c->'d->'e->'f) -> 'a->'b->'c->'d->'e->'f
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Formatting
|
||||
============================================================================*)
|
||||
|
||||
(** {3 Formatting } *)
|
||||
|
||||
exception Nothing_to_fmt
|
||||
|
||||
(** Type of functions for formatting ['a] values. *)
|
||||
type 'a formatter = Format.formatter -> 'a -> unit
|
||||
|
||||
(** Type of format strings that make a single call to an ['a formatter]. *)
|
||||
type 'a format_str = ('a formatter -> 'a -> unit, Format.formatter, unit) format
|
||||
|
||||
val ifbreakf : ('a, Format.formatter, unit) format -> Format.formatter -> 'a
|
||||
|
||||
val failwithf : ('a, Format.formatter, unit, 'b) format4 -> 'a
|
||||
|
||||
val invalid_argf : ('a, Format.formatter, unit, 'b) format4 -> 'a
|
||||
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Collections
|
||||
============================================================================*)
|
||||
|
||||
(** {2 Collections } *)
|
||||
|
||||
(** Types equipped with an equivalence relation. *)
|
||||
module type EqualityType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
end
|
||||
|
||||
(** Types equipped with a total order. *)
|
||||
module type OrderedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
end
|
||||
|
||||
(** Types equipped with a hash function. *)
|
||||
module type HashedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val hash: t -> int
|
||||
end
|
||||
|
||||
(** Pairs of types equipped with a hash function. *)
|
||||
module HashedTypeTup2 (H0: HashedType) (H1: HashedType)
|
||||
: (HashedType with type t = H0.t * H1.t)
|
||||
|
||||
(** Sets of unordered values. *)
|
||||
module type Set0 = sig
|
||||
type elt
|
||||
type t
|
||||
val empty : t
|
||||
val is_empty : t -> bool
|
||||
val add : elt -> t -> t
|
||||
val singleton : elt -> t
|
||||
val iter : (elt -> unit) -> t -> unit
|
||||
val map : (elt -> elt) -> t -> t
|
||||
val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val map_fold : (elt * 'z -> elt * 'z) -> t * 'z -> t * 'z
|
||||
val kfold : t -> (elt -> ('a->'b) -> 'a->'b) -> ('a->'b) -> 'a->'b
|
||||
val for_all : (elt -> bool) -> t -> bool
|
||||
val exists : (elt -> bool) -> t -> bool
|
||||
val exists_unique : (elt -> bool) -> t -> bool
|
||||
val filter : (elt -> bool) -> t -> t
|
||||
val cardinal : t -> int
|
||||
val of_list : elt list -> t
|
||||
val to_list : t -> elt list
|
||||
val choose : t -> elt
|
||||
val union : t -> t -> t
|
||||
val diff : t -> t -> t
|
||||
end
|
||||
|
||||
module type Set1 = sig
|
||||
include Set0
|
||||
include OrderedType with type t := t
|
||||
val remove : elt -> t -> t
|
||||
val diff_inter_diff : t -> t -> t * t * t
|
||||
end
|
||||
|
|
@ -0,0 +1,321 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
module List = struct
|
||||
include List
|
||||
|
||||
let cons x xs = x :: xs
|
||||
|
||||
let tryfind pred lst = try Some(find pred lst) with Not_found -> None
|
||||
|
||||
let rec no_duplicates = function
|
||||
| [] -> true
|
||||
| x::xs -> if (List.mem x xs) then false else (no_duplicates xs)
|
||||
|
||||
let rec iteri_aux fn i = function
|
||||
| [] -> ()
|
||||
| x::xs -> fn i x; iteri_aux fn (i+1) xs
|
||||
let iteri fn xs = iteri_aux fn 0 xs
|
||||
|
||||
let fold fn l a = fold_left (fun a x -> fn x a) a l
|
||||
|
||||
let foldi fn s z = snd (fold (fun x (i,z) -> (i+1, fn i x z)) s (0, z))
|
||||
|
||||
let fold2 fn xs ys a = fold_left2 (fun a x y -> fn x y a) a xs ys
|
||||
|
||||
let fold3 fn =
|
||||
let rec fold3_fn xs ys zs a =
|
||||
match xs, ys, zs with
|
||||
| [], [], [] -> a
|
||||
| x::xs, y::ys, z::zs -> fold3_fn xs ys zs (fn x y z a)
|
||||
| _ -> invalid_arg "List.fold3: expected equal-length lists"
|
||||
in
|
||||
fold3_fn
|
||||
|
||||
let mapi fn xs = rev (snd (fold (fun x (i,z) -> (i+1, fn i x :: z)) xs (0,[])))
|
||||
|
||||
let map3 fn =
|
||||
let rec map3 xs ys zs =
|
||||
match xs, ys, zs with
|
||||
| [], [], [] -> []
|
||||
| x::xs, y::ys, z::zs -> fn x y z :: map3 xs ys zs
|
||||
| _ -> invalid_arg "List.map3: expected equal-length lists"
|
||||
in
|
||||
map3
|
||||
|
||||
let map_append fn xs ys = fold (fun x ys -> fn x :: ys) xs ys
|
||||
|
||||
let map_to_array fn xs =
|
||||
match xs with
|
||||
| [] -> [||]
|
||||
| hd::tl as xs ->
|
||||
let a = Array.make (List.length xs) (fn hd) in
|
||||
let rec set i = function
|
||||
| [] -> a
|
||||
| hd::tl -> Array.set a i (fn hd); set (i+1) tl
|
||||
in
|
||||
set 1 tl
|
||||
|
||||
let map_fold fn (xs,z) =
|
||||
fold_right (fun x (ys,z) ->
|
||||
let y, z = fn (x,z) in
|
||||
(y::ys, z)
|
||||
) xs ([],z)
|
||||
|
||||
let reduce fn = function
|
||||
| [] -> invalid_arg "List.reduce"
|
||||
| x::xs -> fold fn xs x
|
||||
|
||||
let rec kfold fn xs k a =
|
||||
match xs with
|
||||
| [] -> k a
|
||||
| x::xs -> fn x (kfold fn xs k) a
|
||||
|
||||
let rec kfold2 fn xs ys k a =
|
||||
match xs, ys with
|
||||
| [], [] -> k a
|
||||
| x::xs, y::ys -> fn x y (kfold2 fn xs ys k) a
|
||||
| _ -> invalid_arg "List.kfold2: expected equal-length lists"
|
||||
|
||||
let rec kfold3 fn xs ys zs k a =
|
||||
match xs, ys, zs with
|
||||
| [], [], [] -> k a
|
||||
| x::xs, y::ys, z::zs -> fn x y z (kfold3 fn xs ys zs k) a
|
||||
| _ -> invalid_arg "List.kfold3: expected equal-length lists"
|
||||
|
||||
let rec fold_pairs fn xs a =
|
||||
match xs with
|
||||
| [] -> a
|
||||
| x::xs -> fold (fn x) xs (fold_pairs fn xs a)
|
||||
|
||||
let rec kfold_pairs fn k xs a =
|
||||
match xs with
|
||||
| [] -> k a
|
||||
| x::xs -> kfold (fn x) xs (kfold_pairs fn k xs) a
|
||||
|
||||
let rec fold_product fn xs ys a =
|
||||
match xs with
|
||||
| [] -> a
|
||||
| x::xs -> fold (fn x) ys (fold_product fn xs ys a)
|
||||
|
||||
let rec kfold_product xs ys fn k a =
|
||||
match xs with
|
||||
| [] -> k a
|
||||
| x::xs -> kfold (fn x) ys (kfold_product xs ys fn k) a
|
||||
|
||||
let rec prefixes = function
|
||||
| [] -> [[]]
|
||||
| x :: xs -> [] :: map (fun l -> x :: l) (prefixes xs)
|
||||
|
||||
let rec infixes = function
|
||||
| [] -> [[]]
|
||||
| x :: xs -> fold (fun l z -> (x :: l) :: z) (prefixes xs) (infixes xs)
|
||||
|
||||
let rec powerlist = function
|
||||
| [] -> [[]]
|
||||
| x :: xs ->
|
||||
let pow_xs = powerlist xs in
|
||||
fold (fun l z -> (x :: l) :: z) pow_xs pow_xs
|
||||
|
||||
let combs fn xs ys =
|
||||
let rec loop1 zs xs = function
|
||||
| [] -> [[]]
|
||||
| y :: ys ->
|
||||
let rec loop2 zs a = function
|
||||
| [] -> a
|
||||
| x :: xs ->
|
||||
loop2
|
||||
(x :: zs)
|
||||
(fold (fun comb a -> (fn x y comb) :: a) (loop1 zs xs ys) a)
|
||||
xs
|
||||
in loop2 [] (loop2 [] [] zs) xs
|
||||
in loop1 [] xs ys
|
||||
|
||||
let rec permutations fn xs =
|
||||
let rec loop zs xs ps =
|
||||
match xs with
|
||||
| [] -> ps
|
||||
| x :: xs ->
|
||||
loop (x :: zs) xs
|
||||
(List.fold_left (fn x) ps (permutations fn (zs @ xs)))
|
||||
in
|
||||
if xs = [] then [[]] else loop [] xs []
|
||||
|
||||
let fin_funs xs ys =
|
||||
List.map (List.combine xs) (permutations (fun x ps p -> (x :: p) :: ps) ys)
|
||||
|
||||
let map_partial fn xs =
|
||||
List.fold_right (fun x maybe_ys ->
|
||||
match maybe_ys with
|
||||
| None -> None
|
||||
| Some ys ->
|
||||
match fn x with
|
||||
| None -> None
|
||||
| Some y -> Some (y::ys)
|
||||
) xs (Some [])
|
||||
|
||||
let classify fn xs =
|
||||
let rec classify_one x = function
|
||||
| xs :: xss when fn x (List.hd xs) -> (x :: xs) :: xss
|
||||
| xs :: xss -> xs :: (classify_one x xss)
|
||||
| [] -> [[x]]
|
||||
in
|
||||
fold classify_one xs []
|
||||
|
||||
let divide fn ys =
|
||||
let rec divide_ xss ys =
|
||||
match xss, ys with
|
||||
| xs :: xss, y :: ys when fn y (List.hd xs) -> divide_ ((y :: xs) :: xss) ys
|
||||
| xss, y :: ys -> divide_ ([y] :: xss) ys
|
||||
| xss, [] -> List.rev_map List.rev xss
|
||||
in
|
||||
divide_ [] ys
|
||||
|
||||
let rec range i j = if i <= j then i::(range (i+1) j) else []
|
||||
|
||||
let rec replicate n x =
|
||||
if n <= 0 then [] else x :: replicate (n-1) x
|
||||
|
||||
let inter xs ys = List.filter (fun x -> List.mem x ys) xs
|
||||
|
||||
let union xs ys = fold (fun x us -> if List.mem x us then us else x::us) xs ys
|
||||
|
||||
let diff xs rs = find_all (fun x -> not (List.mem x rs)) xs
|
||||
|
||||
let rec take_ p ys xs =
|
||||
match xs with
|
||||
| x :: xs ->
|
||||
if p x then
|
||||
(x, rev_append ys xs)
|
||||
else
|
||||
take_ p (x :: ys) xs
|
||||
| [] ->
|
||||
raise Not_found
|
||||
|
||||
let take p xs =
|
||||
take_ p [] xs
|
||||
|
||||
let exists_unique p xs =
|
||||
let module M = struct exception Found end in
|
||||
try
|
||||
fold (fun x found ->
|
||||
if found
|
||||
then not (p x) || raise M.Found
|
||||
else p x
|
||||
) xs false
|
||||
with M.Found -> false
|
||||
|
||||
let rec equal fn xs ys =
|
||||
if xs == ys then true else
|
||||
match xs,ys with
|
||||
| [], [] -> true
|
||||
| [], _::_
|
||||
| _::_, [] -> false
|
||||
| x::xs, y::ys -> fn x y && equal fn xs ys
|
||||
|
||||
let rec compare fn xs ys =
|
||||
if xs == ys then 0 else
|
||||
match xs,ys with
|
||||
| [], _::_ -> -1
|
||||
| [], [] -> 0
|
||||
| _::_, [] -> 1
|
||||
| x::xs, y::ys -> compare_tup2 fn (compare fn) (x,xs) (y,ys)
|
||||
|
||||
let rec compare_lex fn xs ys =
|
||||
if xs == ys then 0 else
|
||||
match xs,ys with
|
||||
| [], _::_ -> -1
|
||||
| [], [] -> 0
|
||||
| _::_, [] -> 1
|
||||
| x::xs, y::ys -> compare_tup2 (compare_lex fn) fn (xs,x) (ys,y)
|
||||
|
||||
let compare_sorted cmp xs ys =
|
||||
if xs == ys then 0 else
|
||||
let rec loop xs ys = match xs,ys with
|
||||
| [], _::_ -> -1
|
||||
| [], [] -> 0
|
||||
| _::_, [] -> 1
|
||||
| x::xs, y::ys -> compare_tup2 cmp loop (x,xs) (y,ys)
|
||||
in
|
||||
loop (fast_sort cmp xs) (fast_sort cmp ys)
|
||||
|
||||
let fmt sep fn ff xs =
|
||||
let rec aux ff = function
|
||||
| [] -> ()
|
||||
| [x] -> (try fn ff x with Nothing_to_fmt -> ())
|
||||
| x::xs ->
|
||||
try Format.fprintf ff "%a%( fmt %)%a" fn x sep aux xs
|
||||
with Nothing_to_fmt -> aux ff xs
|
||||
in
|
||||
aux ff xs
|
||||
|
||||
let fmtt sep ff xs =
|
||||
let rec aux ff = function
|
||||
| [] -> ()
|
||||
| [x] -> (try x ff with Nothing_to_fmt -> ())
|
||||
| x::xs ->
|
||||
try Format.fprintf ff "%t%( fmt %)%a" x sep aux xs
|
||||
with Nothing_to_fmt -> aux ff xs
|
||||
in
|
||||
aux ff xs
|
||||
|
||||
module Set (Elt: sig type t end) = struct
|
||||
type elt = Elt.t
|
||||
type t = elt list
|
||||
|
||||
let empty = []
|
||||
let is_empty s = s = []
|
||||
let add e s = e :: s
|
||||
let singleton e = [e]
|
||||
let iter = iter
|
||||
let map = map
|
||||
let fold = fold
|
||||
let map_fold = map_fold
|
||||
let kfold fn s z = kfold s fn z
|
||||
let for_all = for_all
|
||||
let exists = exists
|
||||
let exists_unique = exists_unique
|
||||
let filter = filter
|
||||
let cardinal = length
|
||||
let of_list s = s
|
||||
let to_list s = s
|
||||
let choose = function x::_ -> x | [] -> raise Not_found
|
||||
let union = rev_append
|
||||
let diff = diff
|
||||
end
|
||||
|
||||
module SetOrd (Elt: OrderedType) = struct
|
||||
include Set(Elt)
|
||||
let equal x y = equal Elt.equal x y
|
||||
let compare x y = compare Elt.compare x y
|
||||
|
||||
let rec remove x = function
|
||||
| [] -> []
|
||||
| y::ys when Elt.equal x y -> ys
|
||||
| y::ys -> y :: remove x ys
|
||||
|
||||
let diff_inter_diff xs ys =
|
||||
let xs = fast_sort Elt.compare xs
|
||||
and ys = fast_sort Elt.compare ys in
|
||||
let rec did xxs yys =
|
||||
match xxs, yys with
|
||||
| [], ys -> ([], [], ys)
|
||||
| xs, [] -> (xs, [], [])
|
||||
| x::xs, y::ys ->
|
||||
let o = Elt.compare x y in
|
||||
if o = 0 then
|
||||
let xs_ys, i, ys_xs = did xs ys in
|
||||
(xs_ys, x::i, ys_xs)
|
||||
else if o < 0 then
|
||||
let xs_yys, i, yys_xs = did xs yys in
|
||||
(x::xs_yys, i, yys_xs)
|
||||
else
|
||||
let xxs_ys, i, ys_xxs = did xxs ys in
|
||||
(xxs_ys, i, y::ys_xxs)
|
||||
in
|
||||
did xs ys
|
||||
end
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,130 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
(** Operations on ['a list]. See also standard
|
||||
{{:file:../../../doc/ocaml%20manual/libref/List.html}List}. *)
|
||||
|
||||
module List : sig
|
||||
include module type of List
|
||||
|
||||
val cons : 'a -> 'a list -> 'a list
|
||||
|
||||
val tryfind : ('a -> bool) -> 'a list -> 'a option
|
||||
val no_duplicates : 'a list -> bool
|
||||
|
||||
val exists_unique : ('a -> bool) -> 'a list -> bool
|
||||
|
||||
val iteri : (int -> 'a -> unit) -> 'a list -> unit
|
||||
val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
|
||||
val fold : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
|
||||
(** Fold over the elements in the list.
|
||||
Eg: [fold f \[a0;a1;…;aN\] z] = [f aN (…(f a1 (f a0 z))…)] *)
|
||||
val foldi : (int -> 'a -> 'b -> 'b) -> 'a list -> 'b -> 'b
|
||||
|
||||
val map_append : ('a -> 'b) -> 'a list -> 'b list -> 'b list
|
||||
|
||||
val map_to_array : ('a -> 'b) -> 'a list -> 'b array
|
||||
|
||||
val reduce : ('a -> 'a -> 'a) -> 'a list -> 'a
|
||||
val map3 : ('a -> 'b -> 'c -> 'z) -> 'a list -> 'b list -> 'c list -> 'z list
|
||||
val fold2 : ('a -> 'b -> 'z -> 'z) -> 'a list -> 'b list -> 'z -> 'z
|
||||
(** Fold over the corresponding elements in the two lists. The lists must
|
||||
have the same length.
|
||||
Eg: [fold2 f \[a0;a1;…;aN\] \[b0;b1;…;bN\] z]
|
||||
= [f aN bN (…(f a1 b1 (f a0 b0 z))…)] *)
|
||||
|
||||
val fold3 : ('a -> 'b -> 'c -> 'z -> 'z) -> 'a list -> 'b list -> 'c list -> 'z -> 'z
|
||||
|
||||
val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
|
||||
val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
|
||||
val compare_lex : ('a -> 'a -> int) -> 'a list -> 'a list -> int
|
||||
val compare_sorted : ('a -> 'a -> int) -> 'a list -> 'a list -> int
|
||||
|
||||
val kfold : ('a -> ('b->'c) -> 'b->'c) -> 'a list -> ('b->'c) -> 'b->'c
|
||||
(** e.g. [kfold (fun x k () -> (-x) :: k ()) [1;2;3;4] (fun()-> []) ()] =
|
||||
[[-1; -2; -3; -4]] *)
|
||||
|
||||
val kfold2 : ('a -> 'b -> ('c->'d) -> 'c->'d) -> 'a list -> 'b list -> ('c->'d) -> 'c->'d
|
||||
val kfold3 : ('a -> 'b -> 'c -> ('d->'e) -> 'd->'e) -> 'a list -> 'b list -> 'c list -> ('d->'e) -> 'd->'e
|
||||
val fold_pairs : ('a -> 'a -> 'b -> 'b) -> 'a list -> 'b -> 'b
|
||||
(** e.g. [fold_pairs (fun x y l -> (x,y)::l) [1;2;3;4] []] =
|
||||
[[(1, 4); (1, 3); (1, 2); (2, 4); (2, 3); (3, 4)]] *)
|
||||
|
||||
val kfold_pairs :
|
||||
('a -> 'a -> ('b->'c) -> 'b->'c) -> ('b->'c) -> 'a list -> 'b->'c
|
||||
(** e.g. [kfold_pairs (fun x y k () -> (x,y)::k()) (fun()->[]) [1;2;3;4] ()] =
|
||||
[[(1, 2); (1, 3); (1, 4); (2, 3); (2, 4); (3, 4)]] *)
|
||||
|
||||
val fold_product : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
|
||||
(** e.g. [fold_product (fun x y l -> (x,y)::l) [1;2;3] [4;5] []] =
|
||||
[[(1, 5); (1, 4); (2, 5); (2, 4); (3, 5); (3, 4)]] *)
|
||||
|
||||
val kfold_product :
|
||||
'a list -> 'b list -> ('a -> 'b -> ('c->'d) -> 'c->'d) -> ('c->'d) -> 'c->'d
|
||||
(** e.g.
|
||||
[kfold_product (fun x y k () -> (x,y)::k()) (fun()->[]) [1;2;3] [4;5] ()]
|
||||
= [[(1, 5); (1, 4); (2, 5); (2, 4); (3, 5); (3, 4)]] *)
|
||||
|
||||
val prefixes : 'a list -> 'a list list
|
||||
(** e.g. [prefixes [1;2;3]] = [[]; [1]; [1;2]; [1;2;3]] *)
|
||||
|
||||
val infixes : 'a list -> 'a list list
|
||||
(** e.g. [infixes [1;2;3]] = [[[1;2;3]; [1;2]; [1]; [2;3]; [2]; [3]; []]] *)
|
||||
|
||||
val powerlist : 'a list -> 'a list list
|
||||
(** e.g. [powerlist [1;2;3]] =
|
||||
[[1;2;3]; [1;2]; [1;3]; [1]; [2;3]; [2]; [3]; []] *)
|
||||
|
||||
val combs :
|
||||
('a -> 'b -> 'c list -> 'c list) -> 'a list -> 'b list -> 'c list list
|
||||
(** e.g., [combs (fun x y l -> (x,y)::l) [1;2;3] [4;5]] =
|
||||
[[[(3, 4); (2, 5)]; [(3, 4); (1, 5)]; [(2, 4); (1, 5)]; [(2, 4); (3, 5)];
|
||||
[(1, 4); (2, 5)]; [(1, 4); (3, 5)]]] *)
|
||||
|
||||
val permutations :
|
||||
('a -> 'b list list -> 'b list -> 'b list list) -> 'a list -> 'b list list
|
||||
(** [permutations xs] returns all the permutations of [xs], e.g.
|
||||
[permutations (fun x ps p -> (x :: p) :: ps) [1;2;3]] =
|
||||
[[3; 2; 1]; [3; 1; 2]; [2; 1; 3]; [2; 3; 1]; [1; 2; 3]; [1; 3; 2]] *)
|
||||
|
||||
val fin_funs : 'a list -> 'b list -> ('a * 'b) list list
|
||||
(** [fin_funs [1;2;3] [4;5;6]] =
|
||||
[[(1, 4); (2, 5); (3, 6)]; [(1, 4); (2, 6); (3, 5)];
|
||||
[(1, 5); (2, 4); (3, 6)]; [(1, 5); (2, 6); (3, 4)];
|
||||
[(1, 6); (2, 4); (3, 5)]; [(1, 6); (2, 5); (3, 4)]] *)
|
||||
|
||||
val map_partial : ('a -> 'b option) -> 'a list -> 'b list option
|
||||
|
||||
val classify : ('a -> 'a -> bool) -> 'a list -> 'a list list
|
||||
(** [classify pred xs] partitions [xs] into classes equivalent modulo
|
||||
[pred]. Guarantees that no empty classes are returned. *)
|
||||
|
||||
val divide : ('a -> 'a -> bool) -> 'a list -> 'a list list
|
||||
(** [divide pred xs] divides [xs] into the contiguous sublists of elements equivalent modulo [pred]. Guarantees
|
||||
that no empty sublists are returned. *)
|
||||
|
||||
val range : int -> int -> int list
|
||||
val replicate : int -> 'a -> 'a list
|
||||
|
||||
val inter : 'a list -> 'a list -> 'a list
|
||||
val union : 'a list -> 'a list -> 'a list
|
||||
val diff : 'a list -> 'a list -> 'a list
|
||||
|
||||
val take : ('a -> bool) -> 'a list -> 'a * 'a list
|
||||
(** [take p l] returns the first element of [l] that satisfies [p], and the remainder of [l] *)
|
||||
|
||||
val fmt :
|
||||
(unit,Format.formatter,unit)format -> 'a formatter -> 'a list formatter
|
||||
|
||||
val fmtt :
|
||||
('a, 'b, 'c, 'd, 'd, 'a) format6 ->
|
||||
Format.formatter -> (Format.formatter -> unit) list -> unit
|
||||
|
||||
module Set (Elt: sig type t end) :
|
||||
(Set0 with type elt = Elt.t and type t = Elt.t list)
|
||||
|
||||
module SetOrd (Elt: OrderedType) :
|
||||
(Set1 with type elt = Elt.t and type t = Elt.t list)
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,188 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSList
|
||||
open NSSet
|
||||
|
||||
|
||||
module Map = struct
|
||||
module type S = sig
|
||||
include Map.S
|
||||
val tryfind : key -> 'a t -> 'a option
|
||||
val exists_unique : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val extract : key -> 'a t -> 'a * 'a t
|
||||
val modify : ('a -> 'a) -> key -> 'a t -> 'a t
|
||||
val modify_add : ('a -> 'a) -> key -> 'a -> 'a t -> 'a t
|
||||
val pop : 'a t -> (key * 'a) * 'a t
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
val map_to_array : (key -> 'a -> 'b) -> 'a t -> 'b array
|
||||
|
||||
(** Sets of Key-Val pairs where the keys of all elements are distinct. *)
|
||||
module Set (Val: OrderedType) : (Set.S with type elt = key * Val.t
|
||||
and type t = Val.t t)
|
||||
end
|
||||
|
||||
module Make (Key: OrderedType) = struct
|
||||
include Map.Make(Key)
|
||||
|
||||
let tryfind k m = try Some(find k m) with Not_found -> None
|
||||
|
||||
let exists_unique _ = failwith "Map.exists_unique unimplemented"
|
||||
|
||||
(* Note: extract, modify*, pop should be implemented with one search *)
|
||||
let extract k m = (find k m, remove k m)
|
||||
|
||||
let modify fn k m = add k (fn (find k m)) m
|
||||
|
||||
let modify_add fn k v m = try modify fn k m with Not_found -> add k v m
|
||||
|
||||
let pop m =
|
||||
let k,v = choose m in
|
||||
((k,v), remove k m)
|
||||
|
||||
let to_list = bindings
|
||||
|
||||
let map_to_array fn m =
|
||||
let len = cardinal m in
|
||||
if len = 0 then [||]
|
||||
else
|
||||
let (k,v),m = pop m in
|
||||
let a = Array.make len (fn k v) in
|
||||
let i = ref 0 in
|
||||
iter (fun k v -> incr i ; Array.set a !i (fn k v)) m ;
|
||||
a
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Map.Set
|
||||
============================================================================*)
|
||||
|
||||
module Set (Val: OrderedType) = struct
|
||||
|
||||
type elt = Key.t * Val.t
|
||||
type _t = Val.t t
|
||||
type t = _t
|
||||
|
||||
(* constructors *)
|
||||
|
||||
let empty = empty
|
||||
|
||||
let add (k,v) s =
|
||||
match tryfind k s with
|
||||
| None -> add k v s
|
||||
| Some(w) when Val.equal v w -> s
|
||||
| Some _ ->
|
||||
invalid_arg "Map.Set.add: element with same key already exists"
|
||||
|
||||
let adds l s = List.fold add l s
|
||||
|
||||
let singleton kv = add kv empty
|
||||
|
||||
let of_list l = List.fold_right add l empty
|
||||
|
||||
let remove (k,v) s =
|
||||
match tryfind k s with
|
||||
| Some(w) when Val.equal v w -> remove k s
|
||||
| _ -> s
|
||||
|
||||
let fold fn s a = fold (fun x y -> fn (x,y)) s a
|
||||
|
||||
(* Warning: union is ill-defined *)
|
||||
let union = fold add
|
||||
let unions _ = failwith "Map.unions unimplemented"
|
||||
let inter _ = failwith "Map.inter unimplemented"
|
||||
let inters _ = failwith "Map.inters unimplemented"
|
||||
let diff _ = failwith "Map.diff unimplemented"
|
||||
|
||||
let mem (k,v) s =
|
||||
match tryfind k s with
|
||||
| Some(w) -> Val.equal v w
|
||||
| None -> false
|
||||
|
||||
let diff_inter_diff s t =
|
||||
fold (fun a ((s_m_i,i,t_m_i) as acc) ->
|
||||
if mem a t
|
||||
then (remove a s_m_i, add a i, remove a t_m_i)
|
||||
else acc
|
||||
) s (s,empty,t)
|
||||
|
||||
let diff_diff _ = failwith "Map.diff_diff unimplemented"
|
||||
let inter_diff _ = failwith "Map.inter_diff unimplemented"
|
||||
|
||||
let map fn s = fold (fun kv t -> add (fn kv) t) s empty
|
||||
|
||||
let map_fold _ = failwith "Map.map_fold unimplemented"
|
||||
let map_foldi _ = failwith "Map.map_foldi unimplemented"
|
||||
let filter _ = failwith "Map.filter unimplemented"
|
||||
let partition _ = failwith "Map.partition unimplemented"
|
||||
let split _ = failwith "Map.split unimplemented"
|
||||
|
||||
(* queries / destructors *)
|
||||
|
||||
let is_empty = is_empty
|
||||
|
||||
let compare = compare Val.compare
|
||||
let equal = equal Val.equal
|
||||
|
||||
let subset s t = fold (fun kv a -> a && mem kv t) s true
|
||||
|
||||
let disjoint _ = failwith "Map.disjoint unimplemented"
|
||||
let intersect _ = failwith "Map.intersect unimplemented"
|
||||
|
||||
let iter fn s = iter (fun k v -> fn (k,v)) s
|
||||
|
||||
let foldr _ = failwith "Map.foldr unimplemented"
|
||||
let foldi _ = failwith "Map.foldi unimplemented"
|
||||
let fold_pairs _ = failwith "Map.fold_pairs unimplemented"
|
||||
|
||||
let fold_product fn xs ys =
|
||||
fold (fun x -> fold (fun y -> fn x y) ys) xs
|
||||
|
||||
let fold2 _ = failwith "Map.fold2 unimplemented"
|
||||
|
||||
let kfold x fn k = List.kfold fn (to_list x) k
|
||||
|
||||
let for_all _ = failwith "Map.for_all unimplemented"
|
||||
let exists _ = failwith "Map.exists unimplemented"
|
||||
let exists_unique _ = failwith "Map.exists_unique unimplemented"
|
||||
|
||||
let cardinal = cardinal
|
||||
|
||||
let to_list = bindings
|
||||
|
||||
let to_array _ = failwith "Map.to_array unimplemented"
|
||||
|
||||
let min_elt _ = failwith "Map.min_elt unimplemented"
|
||||
let max_elt _ = failwith "Map.max_elt unimplemented"
|
||||
let next _ = failwith "Map.next unimplemented"
|
||||
|
||||
let choose = choose
|
||||
|
||||
exception Found of elt
|
||||
let trychoose s =
|
||||
try iter (fun kv -> raise (Found(kv))) s ; None
|
||||
with Found(kv) -> Some(kv)
|
||||
|
||||
let extract _ = failwith "NSMap.Lift.extract unimplemented"
|
||||
let tryextract _ = failwith "NSMap.Lift.tryextract unimplemented"
|
||||
|
||||
let take _ _ = failwith "Map.take unimplemented"
|
||||
|
||||
let trytake p s =
|
||||
try Some(take p s) with Not_found -> None
|
||||
|
||||
let take_first_pair _ = failwith "Map.take_first_pair unimplemented"
|
||||
let the_only _ = failwith "Map.the_only unimplemented"
|
||||
let reduce _ = failwith "NSMap.Lift.reduce unimplemented"
|
||||
let classify _ = failwith "NSMap.Lift.classify unimplemented"
|
||||
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
module IntMap = Map.Make(struct
|
||||
type t = int
|
||||
let compare = (Pervasives.compare : int -> int -> int)
|
||||
let equal = (Pervasives.( = ) : int -> int -> bool)
|
||||
end)
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSSet
|
||||
|
||||
|
||||
(** Maps from ordered keys to single values. See also standard
|
||||
{{:file:../../../doc/ocaml%20manual/libref/Map.html}Map}. *)
|
||||
module Map : sig
|
||||
module type S = sig
|
||||
include Map.S
|
||||
val tryfind : key -> 'a t -> 'a option
|
||||
val exists_unique : (key -> 'a -> bool) -> 'a t -> bool
|
||||
val extract : key -> 'a t -> 'a * 'a t
|
||||
val modify : ('a -> 'a) -> key -> 'a t -> 'a t
|
||||
val modify_add : ('a -> 'a) -> key -> 'a -> 'a t -> 'a t
|
||||
val pop : 'a t -> (key * 'a) * 'a t
|
||||
val to_list : 'a t -> (key * 'a) list
|
||||
val map_to_array : (key -> 'a -> 'b) -> 'a t -> 'b array
|
||||
|
||||
(*============================================================================
|
||||
Map.Set
|
||||
============================================================================*)
|
||||
|
||||
(** Sets of Key-Val pairs where the keys of all elements are distinct. *)
|
||||
module Set (Val: OrderedType) : (Set.S with type elt = key * Val.t
|
||||
and type t = Val.t t)
|
||||
end
|
||||
|
||||
module Make (Key: OrderedType) : S with type key = Key.t
|
||||
end
|
||||
|
||||
|
||||
module IntMap : Map.S with type key = int
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSMultiSet
|
||||
open NSMultiIndexedSet
|
||||
open NSMultiMap
|
||||
open NSList
|
||||
|
||||
|
||||
module MultiIndexedMultiSet = struct
|
||||
module type S = sig
|
||||
include MultiSet.S
|
||||
type elts
|
||||
type idx
|
||||
val memi : idx -> t -> bool
|
||||
val find : idx -> t -> elts
|
||||
val keys : t -> idx list
|
||||
end
|
||||
|
||||
module Make (Idx: MultiIndexedType) (EltSet: Set0 with type elt = Idx.t) = struct
|
||||
module Key = struct
|
||||
type t = Idx.idx
|
||||
let equal = Idx.equal_idx
|
||||
let compare = Idx.compare_idx
|
||||
end
|
||||
|
||||
module M = MultiMap.Make (Key) (EltSet)
|
||||
|
||||
type idx = Idx.idx
|
||||
type elt = Idx.t
|
||||
type elts = EltSet.t
|
||||
type t = M.t
|
||||
|
||||
let empty = M.empty
|
||||
let is_empty s = M.is_empty s
|
||||
let add e s = M.add (Idx.index e) e s
|
||||
let singleton e = add e empty
|
||||
let iter fn s = M.iter (fun _ e -> fn e) s
|
||||
let map fn s = M.map fn s
|
||||
let fold fn s z = M.fold (fun _ e z -> fn e z) s z
|
||||
let map_fold _ _ = failwith "ToDo: MultiIndexedMultiSet.map_fold"
|
||||
let kfold _ _ _ _ = failwith "ToDo: MultiIndexedMultiSet.kfold"
|
||||
let for_all _ _ = failwith "ToDo: MultiIndexedMultiSet.for_all"
|
||||
let exists _ _ = failwith "ToDo: MultiIndexedMultiSet.exists"
|
||||
let exists_unique _ _ = failwith "ToDo: MultiIndexedMultiSet.exists_unique"
|
||||
let filter fn s = M.filter (fun _ e -> fn e) s
|
||||
let cardinal s = M.length s
|
||||
let of_list es = List.fold add es empty
|
||||
let to_list s = fold List.cons s []
|
||||
let choose _ = failwith "ToDo: MultiIndexedMultiSet.choose"
|
||||
let union _ _ = failwith "ToDo: MultiIndexedMultiSet.union"
|
||||
let diff _ _ = failwith "ToDo: MultiIndexedMultiSet.diff"
|
||||
let equal _ _ = failwith "ToDo: MultiIndexedMultiSet.equal"
|
||||
let compare _ _ = failwith "ToDo: MultiIndexedMultiSet.compare"
|
||||
let remove _ _ = failwith "ToDo: MultiIndexedMultiSet.remove"
|
||||
let foldm fn s z = M.fold_keys (fun _ es z -> fn (EltSet.choose es) (EltSet.cardinal es) z) s z
|
||||
let fold_pairs _ _ _ = failwith "ToDo: MultiIndexedMultiSet.fold_pairs"
|
||||
let memi i s = M.mem i s
|
||||
let find i s = M.find i s
|
||||
let keys s = M.fold_keys (fun i _ is -> i :: is) s []
|
||||
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSMultiSet
|
||||
open NSMultiIndexedSet
|
||||
|
||||
|
||||
module MultiIndexedMultiSet : sig
|
||||
module type S = sig
|
||||
include MultiSet.S
|
||||
type idx
|
||||
type elts
|
||||
val memi : idx -> t -> bool
|
||||
val find : idx -> t -> elts
|
||||
val keys : t -> idx list
|
||||
end
|
||||
|
||||
module Make (Idx: MultiIndexedType) (EltSet: Set0 with type elt = Idx.t) :
|
||||
(S with type idx = Idx.idx and type elt = Idx.t and type elts = EltSet.t)
|
||||
end
|
||||
|
|
@ -0,0 +1,258 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSList
|
||||
open NSSet
|
||||
open NSMap
|
||||
|
||||
|
||||
module type MultiIndexedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
type idx
|
||||
val index : t -> idx
|
||||
val indices : t -> idx list
|
||||
val equal_idx : idx -> idx -> bool
|
||||
val compare_idx : idx -> idx -> int
|
||||
end
|
||||
|
||||
(** Sets of [MultiIndexedType]s, where a [MultiIndexedType] is an
|
||||
[OrderedType] where each value [v] is associated with some indices
|
||||
[indices v], one of which [index v] is primary. The [indices] of all
|
||||
values in a [MultiIndexedSet] are required to be disjoint. *)
|
||||
module MultiIndexedSet = struct
|
||||
module type S = sig
|
||||
include Set.S
|
||||
type idx
|
||||
val memi : idx -> t -> bool
|
||||
val find : idx -> t -> elt
|
||||
val tryfind : idx -> t -> elt option
|
||||
val keys : t -> idx list
|
||||
end
|
||||
|
||||
module Make(Val: MultiIndexedType) = struct
|
||||
|
||||
module Key = struct
|
||||
type t = Val.idx
|
||||
let equal = Val.equal_idx
|
||||
let compare = Val.compare_idx
|
||||
end
|
||||
|
||||
module M = Map.Make(Key)
|
||||
|
||||
type elt = Val.t
|
||||
type t = Val.t M.t
|
||||
|
||||
|
||||
(* constructors *)
|
||||
|
||||
let empty = M.empty
|
||||
|
||||
let add v m =
|
||||
List.fold_left (fun m i ->
|
||||
assert(
|
||||
(try Val.equal v (M.find i m) with Not_found -> true)
|
||||
|| invalid_arg "MultiIndexedSet: indices must be disjoint"
|
||||
);
|
||||
M.add i v m
|
||||
) m (Val.indices v)
|
||||
|
||||
let adds l s = List.fold add l s
|
||||
|
||||
let singleton v = add v empty
|
||||
|
||||
let of_list vl = List.fold add vl empty
|
||||
|
||||
let remove v s =
|
||||
List.fold_left (fun s i ->
|
||||
try if Val.equal v (M.find i s) then M.remove i s else s
|
||||
with Not_found -> s
|
||||
) s (Val.indices v)
|
||||
|
||||
let union m n =
|
||||
M.merge (fun _ vo0 vo1 ->
|
||||
match vo0, vo1 with
|
||||
| None , None -> None
|
||||
| Some _ , None -> vo0
|
||||
| None , Some _ -> vo1
|
||||
| Some(v0), Some(v1) -> vo0
|
||||
$> assert(
|
||||
Val.equal v0 v1
|
||||
|| invalid_arg "MultiIndexedSet: indices must be disjoint"
|
||||
)
|
||||
) m n
|
||||
|
||||
let unions = function
|
||||
| [] -> empty
|
||||
| m :: [] -> m
|
||||
| m :: ml -> List.fold union ml m
|
||||
|
||||
let inter m n =
|
||||
M.merge (fun _ vo0 vo1 ->
|
||||
match vo0, vo1 with
|
||||
| None , _ -> None
|
||||
| _ , None -> None
|
||||
| Some(v0), Some(v1) -> vo0
|
||||
$> assert(
|
||||
Val.equal v0 v1
|
||||
|| invalid_arg "MultiIndexedSet: indices must be disjoint"
|
||||
)
|
||||
) m n
|
||||
|
||||
let inters = function
|
||||
| [] -> invalid_arg "MultiIndexedSet.inters: must be non-nil"
|
||||
| m :: [] -> m
|
||||
| m :: ml -> List.fold inter ml m
|
||||
|
||||
let diff m n =
|
||||
M.merge (fun _ vo0 vo1 ->
|
||||
match vo0, vo1 with
|
||||
| None , _ -> None
|
||||
| _ , None -> vo0
|
||||
| Some(v0), Some(v1) -> None
|
||||
$> assert(
|
||||
Val.equal v0 v1
|
||||
|| invalid_arg "MultiIndexedSet: indices must be disjoint"
|
||||
)
|
||||
) m n
|
||||
|
||||
let fold f m z =
|
||||
M.fold (fun i v z ->
|
||||
if Val.equal_idx i (Val.index v) then f v z else z
|
||||
) m z
|
||||
|
||||
let mem v s =
|
||||
try Val.equal v (M.find (Val.index v) s)
|
||||
with Not_found -> false
|
||||
|
||||
let diff_inter_diff s t =
|
||||
fold (fun a ((s_m_i, i, t_m_i) as acc) ->
|
||||
if mem a t
|
||||
then (remove a s_m_i, add a i, remove a t_m_i)
|
||||
else acc
|
||||
) s (s, empty, t)
|
||||
|
||||
let diff_diff s t =
|
||||
let s_m_i, _, t_m_i = diff_inter_diff s t in
|
||||
(s_m_i, t_m_i)
|
||||
|
||||
let inter_diff s t =
|
||||
let _, i, t_m_i = diff_inter_diff s t in
|
||||
(i, t_m_i)
|
||||
|
||||
let map fn s = fold (fun kv t -> add (fn kv) t) s empty
|
||||
|
||||
let map_fold _ = failwith "ToDo: MultiIndexedSet.map_fold"
|
||||
let map_foldi _ = failwith "ToDo: MultiIndexedSet.map_foldi"
|
||||
|
||||
let filter p m = M.filter (fun _ v -> p v) m
|
||||
|
||||
let partition p m = M.partition (fun _ v -> p v) m
|
||||
|
||||
let split v m =
|
||||
let lt, eq, gt = M.split (Val.index v) m in
|
||||
(lt, eq <> None, gt)
|
||||
|
||||
(* queries / destructors *)
|
||||
|
||||
let is_empty = M.is_empty
|
||||
|
||||
let compare m n = M.compare Val.compare m n
|
||||
|
||||
let equal m n = M.equal Val.equal m n
|
||||
|
||||
let subset m n = is_empty (diff m n)
|
||||
|
||||
let disjoint _ = failwith "ToDo: MultiIndexedSet.disjoint"
|
||||
let intersect _ = failwith "ToDo: MultiIndexedSet.intersect"
|
||||
|
||||
let iter f m =
|
||||
M.iter (fun i v ->
|
||||
if Val.equal_idx i (Val.index v) then f v
|
||||
) m
|
||||
|
||||
let foldr _ = failwith "ToDo: MultiIndexedSet.foldr"
|
||||
let foldi _ = failwith "ToDo: MultiIndexedSet.foldi"
|
||||
let fold_pairs _ = failwith "ToDo: MultiIndexedSet.fold_pairs"
|
||||
|
||||
let fold_product fn xs ys =
|
||||
fold (fun x -> fold (fun y -> fn x y) ys) xs
|
||||
|
||||
let fold2 _ = failwith "ToDo: MultiIndexedSet.fold2"
|
||||
|
||||
let to_list m =
|
||||
M.fold (fun i v z ->
|
||||
if Val.equal_idx i (Val.index v) then v :: z else z
|
||||
) m []
|
||||
|
||||
let kfold x fn k = List.kfold fn (to_list x) k
|
||||
|
||||
let for_all p m =
|
||||
M.for_all (fun i v ->
|
||||
not (Val.equal_idx i (Val.index v)) || p v
|
||||
) m
|
||||
|
||||
let exists p m =
|
||||
M.exists (fun i v ->
|
||||
Val.equal_idx i (Val.index v) && p v
|
||||
) m
|
||||
|
||||
let exists_unique p m =
|
||||
M.exists_unique (fun i v ->
|
||||
Val.equal_idx i (Val.index v) && p v
|
||||
) m
|
||||
|
||||
let cardinal m =
|
||||
M.fold (fun i v c ->
|
||||
if Val.equal_idx i (Val.index v) then succ c else c
|
||||
) m 0
|
||||
|
||||
let to_array _ = failwith "ToDo: MultiIndexedSet.to_array"
|
||||
|
||||
let keys m = M.fold (fun i _ z -> i :: z) m []
|
||||
|
||||
let min_elt m = snd (M.min_binding m)
|
||||
|
||||
let max_elt m = snd (M.max_binding m)
|
||||
|
||||
let next _ = failwith "ToDo: MultiIndexedSet.next"
|
||||
|
||||
let choose m = snd (M.choose m)
|
||||
|
||||
exception Found of elt
|
||||
let trychoose s =
|
||||
try iter (fun kv -> raise (Found(kv))) s ; None
|
||||
with Found(kv) -> Some(kv)
|
||||
|
||||
let extract _ = failwith "ToDo: NSMultiIndexedSet.Lift.extract"
|
||||
let tryextract _ = failwith "ToDo: NSMultiIndexedSet.Lift.tryextract"
|
||||
|
||||
let take _ _ = failwith "ToDo: MultiIndexedSet.take"
|
||||
|
||||
let trytake p s =
|
||||
try Some(take p s) with Not_found -> None
|
||||
|
||||
let take_first_pair _ = failwith "ToDo: MultiIndexedSet.take_first_pair"
|
||||
let the_only _ = failwith "ToDo: MultiIndexedSet.the_only"
|
||||
|
||||
type idx = Val.idx
|
||||
|
||||
let find i m = M.find i m
|
||||
|
||||
let tryfind i m = M.tryfind i m
|
||||
|
||||
let memi i m = M.mem i m
|
||||
|
||||
let reduce _ = failwith "ToDo: NSMultiIndexedSet.Lift.reduce"
|
||||
|
||||
let classify fn xs =
|
||||
let rec classify_one x = function
|
||||
| xs :: xss when fn x (List.hd xs) -> (x :: xs) :: xss
|
||||
| xs :: xss -> xs :: (classify_one x xss)
|
||||
| [] -> [[x]]
|
||||
in
|
||||
fold classify_one xs []
|
||||
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSSet
|
||||
|
||||
|
||||
module type MultiIndexedType = sig
|
||||
type t
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
type idx
|
||||
val index : t -> idx
|
||||
val indices : t -> idx list
|
||||
val equal_idx : idx -> idx -> bool
|
||||
val compare_idx : idx -> idx -> int
|
||||
end
|
||||
|
||||
module MultiIndexedSet : sig
|
||||
module type S = sig
|
||||
include Set.S
|
||||
type idx
|
||||
val memi : idx -> t -> bool
|
||||
val find : idx -> t -> elt
|
||||
val tryfind : idx -> t -> elt option
|
||||
val keys : t -> idx list
|
||||
end
|
||||
|
||||
module Make(Idx: MultiIndexedType) :
|
||||
(S with type elt = Idx.t and type idx = Idx.idx)
|
||||
end
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSMap
|
||||
|
||||
|
||||
module MultiMap = struct
|
||||
module type S = sig
|
||||
type k
|
||||
type v
|
||||
type vs
|
||||
type t
|
||||
|
||||
val empty : t
|
||||
val add : k -> v -> t -> t
|
||||
val union : k -> vs -> t -> t
|
||||
val diff : k -> vs -> t -> t
|
||||
val replace : k -> vs -> t -> t
|
||||
val remove : k -> t -> t
|
||||
|
||||
val is_empty : t -> bool
|
||||
val length : t -> int
|
||||
val mem : k -> t -> bool
|
||||
val find : k -> t -> vs
|
||||
|
||||
val iter : (k -> v -> unit) -> t -> unit
|
||||
val iter_keys : (k -> vs -> unit) -> t -> unit
|
||||
val exists : (k -> v -> bool) -> t -> bool
|
||||
val existsi : k -> (v -> bool) -> t -> bool
|
||||
val filter : (k -> v -> bool) -> t -> t
|
||||
val filteri : k -> (v -> bool) -> t -> t
|
||||
val map : (v -> v) -> t -> t
|
||||
val mapi : (k -> v -> v) -> t -> t
|
||||
val fold : (k -> v -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_keys : (k -> vs -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val to_list : t -> (k * v) list
|
||||
|
||||
(* val equal : t -> t -> bool *)
|
||||
(* val compare : t -> t -> int *)
|
||||
end
|
||||
|
||||
module Make (Key: OrderedType) (ValSet: Set0) = struct
|
||||
module M = Map.Make(Key)
|
||||
type k = Key.t
|
||||
type v = ValSet.elt
|
||||
type vs = ValSet.t
|
||||
type t = vs M.t
|
||||
|
||||
module S = ValSet
|
||||
|
||||
let empty = M.empty
|
||||
|
||||
let add k v t =
|
||||
match M.tryfind k t with
|
||||
| None -> M.add k (S.singleton v) t
|
||||
| Some(vs) -> M.add k (S.add v vs) t
|
||||
|
||||
let union k vs t =
|
||||
if S.is_empty vs then t else
|
||||
match M.tryfind k t with
|
||||
| None -> M.add k vs t
|
||||
| Some(us) -> M.add k (S.union us vs) t
|
||||
|
||||
let diff k vs t =
|
||||
if S.is_empty vs then t else
|
||||
match M.tryfind k t with
|
||||
| None -> t
|
||||
| Some(us) -> M.add k (S.diff us vs) t
|
||||
|
||||
let replace k vs t = M.add k vs t
|
||||
|
||||
let remove = M.remove
|
||||
|
||||
let is_empty = M.is_empty
|
||||
|
||||
let mem = M.mem
|
||||
|
||||
let find k t = try M.find k t with Not_found -> S.empty
|
||||
|
||||
let iter f t = M.iter (fun k vs -> S.iter (f k) vs) t
|
||||
|
||||
let iter_keys f t = M.iter f t
|
||||
|
||||
let exists p t = M.exists (fun k vs -> S.exists (p k) vs) t
|
||||
|
||||
let existsi k p t = S.exists p (find k t)
|
||||
|
||||
let filter p t =
|
||||
M.fold (fun k vs t ->
|
||||
let vs' = S.filter (p k) vs in
|
||||
if S.is_empty vs'
|
||||
then M.remove k t
|
||||
else M.add k vs' t
|
||||
) t t
|
||||
|
||||
let filteri k p t =
|
||||
match M.tryfind k t with
|
||||
| None -> t
|
||||
| Some(vs) ->
|
||||
let vs' = S.filter p vs in
|
||||
if S.is_empty vs'
|
||||
then M.remove k t
|
||||
else M.add k vs' t
|
||||
|
||||
let map f t = M.map (fun vs -> S.map f vs) t
|
||||
|
||||
let mapi f t = M.mapi (fun k vs -> S.map (f k) vs) t
|
||||
|
||||
let fold f = M.fold (fun k -> S.fold (f k))
|
||||
|
||||
let fold_keys f = M.fold f
|
||||
|
||||
let length m = fold (fun _ _ n -> n+1) m 0
|
||||
|
||||
let to_list m = fold (fun k v es -> (k,v) :: es) m []
|
||||
|
||||
(* let compare = M.compare S.compare *)
|
||||
(* let equal = M.equal S.equal *)
|
||||
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Maps from ordered keys to multiple values. *)
|
||||
module MultiMap : sig
|
||||
module type S = sig
|
||||
type k
|
||||
type v
|
||||
type vs
|
||||
type t
|
||||
|
||||
val empty : t
|
||||
val add : k -> v -> t -> t
|
||||
val union : k -> vs -> t -> t
|
||||
val diff : k -> vs -> t -> t
|
||||
val replace : k -> vs -> t -> t
|
||||
val remove : k -> t -> t
|
||||
|
||||
val is_empty : t -> bool
|
||||
val length : t -> int
|
||||
val mem : k -> t -> bool
|
||||
val find : k -> t -> vs
|
||||
|
||||
val iter : (k -> v -> unit) -> t -> unit
|
||||
val iter_keys : (k -> vs -> unit) -> t -> unit
|
||||
val exists : (k -> v -> bool) -> t -> bool
|
||||
val existsi : k -> (v -> bool) -> t -> bool
|
||||
val filter : (k -> v -> bool) -> t -> t
|
||||
val filteri : k -> (v -> bool) -> t -> t
|
||||
val map : (v -> v) -> t -> t
|
||||
val mapi : (k -> v -> v) -> t -> t
|
||||
val fold : (k -> v -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_keys : (k -> vs -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val to_list : t -> (k * v) list
|
||||
|
||||
(* val equal : t -> t -> bool *)
|
||||
(* val compare : t -> t -> int *)
|
||||
end
|
||||
|
||||
module Make (Key: OrderedType) (ValSet: Set0) :
|
||||
(S with type k = Key.t and type v = ValSet.elt and type vs = ValSet.t)
|
||||
end
|
||||
|
|
@ -0,0 +1,98 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSList
|
||||
open NSMap
|
||||
|
||||
|
||||
module MultiSet = struct
|
||||
module type S = sig
|
||||
include Set0
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
val remove : elt -> t -> t
|
||||
val foldm : (elt -> int -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
val fold_pairs : (elt -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
end
|
||||
|
||||
module Make (Ord: OrderedType) = struct
|
||||
module M = Map.Make(Ord)
|
||||
|
||||
type elt = Ord.t
|
||||
type t = int M.t
|
||||
|
||||
let empty = M.empty
|
||||
|
||||
let is_empty = M.is_empty
|
||||
|
||||
let addn x n s = M.add x (try n + M.find x s with Not_found -> n) s
|
||||
|
||||
let removen x n s = M.add x (try let x = M.find x s - n in if x<0 then 0 else x with Not_found -> 0) s
|
||||
|
||||
let add x s = addn x 1 s
|
||||
|
||||
let singleton x = add x empty
|
||||
|
||||
let union s t = M.fold addn s t
|
||||
|
||||
let choose s = fst (M.choose s)
|
||||
|
||||
let remove x s =
|
||||
try
|
||||
let m = M.find x s in
|
||||
if m = 1
|
||||
then M.remove x s
|
||||
else M.add x (m - 1) s
|
||||
with Not_found -> s
|
||||
|
||||
let diff s t = M.fold removen s t
|
||||
|
||||
let iter f s = M.iter (fun x m -> for _i = 1 to m do f x done) s
|
||||
|
||||
let map f s = M.fold (fun x m t -> addn (f x) m t) s empty
|
||||
|
||||
let fold f s z =
|
||||
M.fold (fun x m z ->
|
||||
let rec loop n z = if n = 0 then z else loop (n-1) (f x z) in
|
||||
loop m z
|
||||
) s z
|
||||
|
||||
let foldm = M.fold
|
||||
|
||||
let map_fold _ = failwith "ToDo: MultiSet.map_fold"
|
||||
|
||||
let kfold _ = failwith "ToDo: MultiSet.kfold"
|
||||
|
||||
let rec fold_pairs fn xs a =
|
||||
try
|
||||
let x = choose xs in
|
||||
let xs = remove x xs in
|
||||
fold (fun a -> fn x a) xs (fold_pairs fn xs a)
|
||||
with
|
||||
Not_found -> a
|
||||
|
||||
let for_all p s = M.for_all (fun x _ -> p x) s
|
||||
|
||||
let exists p s = M.exists (fun x _ -> p x) s
|
||||
|
||||
let exists_unique p s = M.exists_unique (fun x _ -> p x) s
|
||||
|
||||
let filter p s = M.filter (fun x _ -> p x) s
|
||||
|
||||
let cardinal s = M.fold (fun _ m c -> c + m) s 0
|
||||
|
||||
let of_list l = List.fold add l empty
|
||||
|
||||
let to_list s =
|
||||
M.fold (fun x n l ->
|
||||
let rec loop l = function
|
||||
| 0 -> l
|
||||
| n -> loop (x::l) (n-1) in
|
||||
loop l n
|
||||
) s []
|
||||
|
||||
let equal s t = M.equal Pervasives.( = ) s t
|
||||
let compare s t = M.compare Pervasives.compare s t
|
||||
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Multisets of ordered values. *)
|
||||
module MultiSet : sig
|
||||
|
||||
module type S = sig
|
||||
type elt
|
||||
(** The type of multiset elements. *)
|
||||
|
||||
type t
|
||||
(** The type of multisets of elt. *)
|
||||
|
||||
val empty : t
|
||||
(** The empty multiset. *)
|
||||
|
||||
val is_empty : t -> bool
|
||||
|
||||
val add : elt -> t -> t
|
||||
(** [add e s] increases the multiplicity of [e] by one. *)
|
||||
|
||||
val singleton : elt -> t
|
||||
|
||||
val iter : (elt -> unit) -> t -> unit
|
||||
val map : (elt -> elt) -> t -> t
|
||||
val fold : (elt -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
val map_fold : (elt * 'z -> elt * 'z) -> t * 'z -> t * 'z
|
||||
val kfold : t -> (elt -> ('a->'b) -> 'a->'b) -> ('a->'b) -> 'a->'b
|
||||
|
||||
val for_all : (elt -> bool) -> t -> bool
|
||||
val exists : (elt -> bool) -> t -> bool
|
||||
val exists_unique : (elt -> bool) -> t -> bool
|
||||
val filter : (elt -> bool) -> t -> t
|
||||
val cardinal : t -> int
|
||||
|
||||
val of_list : elt list -> t
|
||||
val to_list : t -> elt list
|
||||
(** [to_list s] is a list of the elements of [s], in increasing order,
|
||||
where elements are repeated according to their multiplicities. *)
|
||||
|
||||
val choose : t -> elt
|
||||
|
||||
val union : t -> t -> t
|
||||
(** [union s t] sums the multiplicities of elements of [s] and [t]. *)
|
||||
|
||||
val diff : t -> t -> t
|
||||
|
||||
val equal: t -> t -> bool
|
||||
val compare: t -> t -> int
|
||||
|
||||
val remove : elt -> t -> t
|
||||
|
||||
val foldm : (elt -> int -> 'z -> 'z) -> t -> 'z -> 'z
|
||||
(** [foldm f s z] computes [(f eN mN … (f e2 m2 (f e1 m1 z))…)], where
|
||||
[e1…eN] are the distinct elements of [s], in increasing order, and
|
||||
[m1…mN] are their multiplicities. *)
|
||||
|
||||
val fold_pairs : (elt -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
end
|
||||
|
||||
module Make (Ord: OrderedType) : (S with type elt = Ord.t)
|
||||
end
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
|
||||
(*============================================================================
|
||||
Option
|
||||
============================================================================*)
|
||||
|
||||
module Option = struct
|
||||
|
||||
let option d f = function
|
||||
| Some(x) -> f x
|
||||
| None -> d
|
||||
|
||||
let optionk dk f = function
|
||||
| Some(x) -> f x
|
||||
| None -> dk()
|
||||
|
||||
let is_some = function
|
||||
| Some(_) -> true
|
||||
| None -> false
|
||||
|
||||
let is_none o = not (is_some o)
|
||||
|
||||
let get = function
|
||||
| Some(x) -> x
|
||||
| None -> raise Not_found
|
||||
|
||||
let from_some = get
|
||||
|
||||
let or_get y = function
|
||||
| Some(x) -> x
|
||||
| None -> y
|
||||
|
||||
let from_option = or_get
|
||||
|
||||
let get_or o y =
|
||||
match o with
|
||||
| Some(x) -> x
|
||||
| None -> y
|
||||
|
||||
let some x = Some(x)
|
||||
|
||||
let bind o fn =
|
||||
match o with
|
||||
| Some(x) -> fn x
|
||||
| None -> None
|
||||
|
||||
let flatten = function
|
||||
| Some(x) -> x
|
||||
| None -> None
|
||||
|
||||
let map fn = function
|
||||
| Some(x) -> Some(fn x)
|
||||
| None -> None
|
||||
|
||||
let map2 fn o p =
|
||||
match o,p with
|
||||
| Some(x), Some(y) -> Some(fn x y)
|
||||
| _ -> None
|
||||
|
||||
let map3 fn o p q =
|
||||
match o,p,q with
|
||||
| Some(x), Some(y), Some(z) -> Some(fn x y z)
|
||||
| _ -> None
|
||||
|
||||
let mapN fn os =
|
||||
try Some(fn (Array.map from_some os))
|
||||
with Not_found -> None
|
||||
|
||||
let fold fn o z =
|
||||
match o with
|
||||
| Some(x) -> fn x z
|
||||
| None -> z
|
||||
|
||||
let iter fn o =
|
||||
match o with
|
||||
| Some(x) -> fn x
|
||||
| None -> ()
|
||||
|
||||
(* list operations *)
|
||||
|
||||
let to_list = function
|
||||
| None -> []
|
||||
| Some(x) -> [x]
|
||||
|
||||
let of_list = function
|
||||
| [] -> None
|
||||
| x :: _ -> Some(x)
|
||||
|
||||
let meet o p =
|
||||
match o,p with
|
||||
| Some(x), Some(y) -> Some(x,y)
|
||||
| _ -> None
|
||||
|
||||
let meetN os =
|
||||
try Some(List.map from_some os)
|
||||
with Not_found -> None
|
||||
|
||||
let rec concat = function
|
||||
| [] -> []
|
||||
| Some(x) :: os -> x :: concat os
|
||||
| None :: os -> concat os
|
||||
|
||||
let rec until_none fn a =
|
||||
match fn a with
|
||||
| None -> a
|
||||
| Some(b) -> until_none fn b
|
||||
|
||||
let equal eq_fn o p =
|
||||
match o,p with
|
||||
| None, None -> true
|
||||
| Some(x), Some(y) -> eq_fn x y
|
||||
| _ -> false
|
||||
|
||||
let compare fn o p =
|
||||
match o,p with
|
||||
| Some(x), Some(y) -> fn x y
|
||||
| None, None -> 0
|
||||
| None, _ -> -1
|
||||
| _, None -> 1
|
||||
|
||||
let fmt none fn ff = function
|
||||
| None -> Format.fprintf ff none
|
||||
| Some(x) -> Format.fprintf ff "@[%a@]" fn x
|
||||
|
||||
end
|
||||
|
||||
let ( >>= ) o fn = Option.bind o fn
|
||||
|
||||
let ( =<< ) fn o = Option.bind o fn
|
||||
|
||||
let ( >>== ) o fn = Option.map fn o
|
||||
|
||||
let ( >=> ) f g x = f x >>= g
|
||||
|
||||
let ( <=< ) g f x = f x >>= g
|
||||
|
||||
let ( |+| ) = Option.meet
|
||||
|
||||
let ( !! ) x = Option.from_some(!x)
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Operations on ['a option]. *)
|
||||
module Option : sig
|
||||
|
||||
val option : 'b -> ('a -> 'b) -> 'a option -> 'b
|
||||
(** [option d f o] tranforms [o] with [f] using [d] as a default value. *)
|
||||
|
||||
val optionk : (unit -> 'b) -> ('a -> 'b) -> 'a option -> 'b
|
||||
(** [optionk k f o] tranforms [o] with [f] using [k()] as a default value. *)
|
||||
|
||||
val is_some : 'a option -> bool
|
||||
(** Test for existence of a carried value. *)
|
||||
|
||||
val is_none : 'a option -> bool
|
||||
(** Test for absence of a carried value. *)
|
||||
|
||||
val get : 'a option -> 'a
|
||||
(** Extract carried value, raises [Invalid_argument] if [None]. *)
|
||||
|
||||
val from_some : 'a option -> 'a
|
||||
(** Extract carried value, raises [Invalid_argument] if [None]. *)
|
||||
|
||||
val get_or : 'a option -> 'a -> 'a
|
||||
(** Extract carried value, using given value as a default. *)
|
||||
|
||||
val or_get : 'a -> 'a option -> 'a
|
||||
(** Extract carried value, using given value as a default. *)
|
||||
|
||||
val from_option : 'a -> 'a option -> 'a
|
||||
(** Extract carried value, using given value as a default. *)
|
||||
|
||||
val some : 'a -> 'a option
|
||||
(** Monadic unit for options. *)
|
||||
|
||||
val bind : 'a option -> ('a -> 'b option) -> 'b option
|
||||
(** Monadic bind for options. *)
|
||||
|
||||
val flatten : 'a option option -> 'a option
|
||||
(** Monadic join for options. *)
|
||||
|
||||
val map : ('a -> 'b) -> 'a option -> 'b option
|
||||
(** Monadic lift for options. *)
|
||||
|
||||
val map2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option
|
||||
(** Monadic binary lift for options. *)
|
||||
|
||||
val map3 : ('a->'b->'c->'d) -> 'a option -> 'b option -> 'c option -> 'd option
|
||||
(** Monadic ternary lift for options. *)
|
||||
|
||||
val mapN : ('a array -> 'b) -> 'a option array -> 'b option
|
||||
(** Monadic n-ary lift for options. *)
|
||||
|
||||
val fold : ('a -> 'z -> 'z) -> 'a option -> 'z -> 'z
|
||||
|
||||
val iter : ('a -> unit) -> 'a option -> unit
|
||||
|
||||
val to_list : 'a option -> 'a list
|
||||
(** Convert option to list. *)
|
||||
|
||||
val of_list : 'a list -> 'a option
|
||||
(** Convert (head of) list to option. *)
|
||||
|
||||
val meet : 'a option -> 'b option -> ('a*'b) option
|
||||
(** Smash product. *)
|
||||
|
||||
val meetN : 'a option list -> 'a list option
|
||||
(** Smash product, n-ary. *)
|
||||
|
||||
val concat : 'a option list -> 'a list
|
||||
(** Return list of carried values. *)
|
||||
|
||||
val until_none : ('a -> 'a option) -> 'a -> 'a
|
||||
(** Apply given function to given value repeatedly until [None] results,
|
||||
then return the value that the function mapped to [None]. *)
|
||||
|
||||
val equal : ('a -> 'b -> bool) -> 'a option -> 'b option -> bool
|
||||
(** Equivalence relation on options. *)
|
||||
|
||||
val compare : ('a -> 'b -> int) -> 'a option -> 'b option -> int
|
||||
(** Total order on options, [None] is smaller than [Some]. *)
|
||||
|
||||
val fmt :
|
||||
(unit,Format.formatter,unit)format -> 'a formatter -> 'a option formatter
|
||||
(** Formatter for options, accepting a format string to use for [None] and a
|
||||
formatter for carried values. *)
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
(** {4 Option combinators } *)
|
||||
|
||||
val ( >>= ) : 'a option -> ('a -> 'b option) -> 'b option
|
||||
(** Monadic bind for options, left associative. *)
|
||||
|
||||
val ( =<< ) : ('a -> 'b option) -> 'a option -> 'b option
|
||||
(** Monadic bind for options with arguments flipped, left associative. *)
|
||||
|
||||
val ( >>== ) : 'a option -> ('a -> 'b) -> 'b option
|
||||
(** Monadic lift for options with arguments flipped, left associative. *)
|
||||
|
||||
val ( >=> ) : ('a -> 'b option) -> ('b -> 'c option) -> 'a -> 'c option
|
||||
(** Left-to-right Kleisli composition. *)
|
||||
|
||||
val ( <=< ) : ('b -> 'c option) -> ('a -> 'b option) -> 'a -> 'c option
|
||||
(** Right-to-left Kleisli composition. *)
|
||||
|
||||
val ( |+| ) : 'a option -> 'b option -> ('a * 'b) option
|
||||
(** Smash product. *)
|
||||
|
||||
val ( !! ) : 'a option ref -> 'a
|
||||
(** Dereference possibly-NULL pointer. *)
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSHashtbl
|
||||
|
||||
|
||||
module PolyHMap = struct
|
||||
include Hashtbl
|
||||
let add = replace
|
||||
end
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
|
||||
(** Imperative maps from keys to single values using polymorphic equality and
|
||||
hashing. @deprecated Polymorphic equality is usually wrong, use [HashMap]
|
||||
instead. *)
|
||||
module PolyHMap : sig
|
||||
type ('a, 'b) t
|
||||
|
||||
val create : int -> ('a, 'b) t
|
||||
val clear : ('a, 'b) t -> unit
|
||||
val copy : ('a, 'b) t -> ('a, 'b) t
|
||||
val add : ('a, 'b) t -> 'a -> 'b -> unit
|
||||
val remove : ('a, 'b) t -> 'a -> unit
|
||||
|
||||
val is_empty : ('a, 'b) t -> bool
|
||||
val length : ('a, 'b) t -> int
|
||||
val mem : ('a, 'b) t -> 'a -> bool
|
||||
val find : ('a, 'b) t -> 'a -> 'b
|
||||
val tryfind : ('a, 'b) t -> 'a -> 'b option
|
||||
|
||||
val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
|
||||
val exists : ('a -> 'b -> bool) -> ('a, 'b) t -> bool
|
||||
val filter : ('a -> 'b -> bool) -> ('a,'b) t -> unit
|
||||
val map : ('v -> 'w) -> ('k, 'v) t -> ('k, 'w) t
|
||||
val mapi : ('k -> 'v -> 'w) -> ('k, 'v) t -> ('k, 'w) t
|
||||
val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
|
||||
val to_list : ('a, 'b) t -> ('a * 'b) list
|
||||
end
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSList
|
||||
|
||||
|
||||
module PolySet = struct
|
||||
module type S = sig
|
||||
type 'a elt
|
||||
type 'a t
|
||||
val empty : 'a t
|
||||
val is_empty : 'a t -> bool
|
||||
val add : 'a elt -> 'a t -> 'a t
|
||||
val singleton : 'a elt -> 'a t
|
||||
val iter : ('a elt -> unit) -> 'a t -> unit
|
||||
val map : ('a elt -> 'a elt) -> 'a t -> 'a t
|
||||
val fold : ('a elt -> 'z -> 'z) -> 'a t -> 'z -> 'z
|
||||
val exists : ('a elt -> bool) -> 'a t -> bool
|
||||
val filter : ('a elt -> bool) -> 'a t -> 'a t
|
||||
val mem : 'a elt -> 'a t -> bool
|
||||
val remove : 'a elt -> 'a t -> 'a t
|
||||
val union : 'a t -> 'a t -> 'a t
|
||||
val unions : 'a t list -> 'a t
|
||||
val inter : 'a t -> 'a t -> 'a t
|
||||
val inters : 'a t list -> 'a t
|
||||
val diff : 'a t -> 'a t -> 'a t
|
||||
val diff_diff : 'a t -> 'a t -> 'a t * 'a t
|
||||
val inter_diff : 'a t -> 'a t -> 'a t * 'a t
|
||||
val diff_inter_diff : 'a t -> 'a t -> 'a t * 'a t * 'a t
|
||||
val subset : 'a t -> 'a t -> bool
|
||||
val disjoint : 'a t -> 'a t -> bool
|
||||
val intersect : 'a t -> 'a t -> bool
|
||||
val kfold : 'a t -> ('a elt -> ('y->'z) -> 'y->'z) -> ('y->'z) -> 'y->'z
|
||||
val fold2 : ('z -> 'a elt -> 'a elt -> 'z) -> 'z -> 'a t -> 'a t -> 'z
|
||||
val for_all : ('a elt -> bool) -> 'a t -> bool
|
||||
val partition : ('a elt -> bool) -> 'a t -> 'a t * 'a t
|
||||
val cardinal : 'a t -> int
|
||||
val to_list : 'a t -> 'a elt list
|
||||
val of_list : 'a elt list -> 'a t
|
||||
val to_array : 'a t -> 'a elt array
|
||||
val min_elt : 'a t -> 'a elt
|
||||
val max_elt : 'a t -> 'a elt
|
||||
val choose : 'a t -> 'a elt
|
||||
val trychoose : 'a t -> 'a elt option
|
||||
val split : 'a elt -> 'a t -> 'a t * bool * 'a t
|
||||
val next : 'a elt -> 'a t -> 'a elt
|
||||
val fold_pairs : ('a elt -> 'a elt -> 'z -> 'z) -> 'a t -> 'z -> 'z
|
||||
val fold_product : ('a elt->'a elt -> 'z->'z) -> 'a t->'a t -> 'z->'z
|
||||
val the_only : ('a elt -> bool) -> 'a t -> 'a elt option
|
||||
(* val take : ('a elt -> bool) -> 'a t -> 'a elt option *)
|
||||
val take_first_pair : ('a elt -> 'a elt -> 'z option) -> 'a t -> 'z option
|
||||
val equal : 'a t -> 'a t -> bool
|
||||
val compare : 'a t -> 'a t -> int
|
||||
end
|
||||
|
||||
module Make(Ord: PolySet.OrderedType) = struct
|
||||
include PolySet.Make(Ord)
|
||||
|
||||
let equal x y = if x == y then true else 0 = compare x y
|
||||
|
||||
let union x y = if x == y then x else union x y
|
||||
|
||||
let unions x = List.fold_left union empty x
|
||||
let inters = function
|
||||
| [] -> empty
|
||||
| xs::xss -> List.fold_left inter xs xss
|
||||
|
||||
let diff_inter_diff s t = let i = inter s t in (diff s i, i, diff t i)
|
||||
(* fold (fun a ((s_m_i,i,t_m_i) as acc) -> *)
|
||||
(* if mem a t *)
|
||||
(* then (remove a s_m_i, add a i, remove a t_m_i) *)
|
||||
(* else acc) *)
|
||||
(* s (s,empty,t) *)
|
||||
|
||||
let inter_diff x y = (inter x y, diff x y)
|
||||
let diff_diff x y = let (x_i, _, y_i) = diff_inter_diff x y in (x_i, y_i)
|
||||
|
||||
let disjoint x y = is_empty (inter x y)
|
||||
|
||||
(* Within the implementation of Set, the following implementation (due to
|
||||
Christophe Raffalli [christophe.raffalli@univ-savoie.fr]) should be
|
||||
faster:
|
||||
let rec disjoint t1 t2 =
|
||||
match (t1, t2) with
|
||||
(Empty, _) | (_, Empty) ->
|
||||
true
|
||||
| (Node (l1, v1, r1, _), Node (l2, v2, r2, _)) ->
|
||||
let c = Ord.compare v1 v2 in
|
||||
if c = 0 then
|
||||
false
|
||||
else if c < 0 then
|
||||
disjoint (Node (l1, v1, Empty, 0)) l2 && disjoint r1 t2
|
||||
else
|
||||
disjoint l1 (Node (l2, v2, Empty, 0)) && disjoint t1 r2
|
||||
*)
|
||||
|
||||
let intersect x y = not (disjoint x y)
|
||||
|
||||
let map fn s = fold (fun kv t -> add (fn kv) t) s empty
|
||||
|
||||
let to_list = elements
|
||||
|
||||
let kfold x fn k = List.kfold fn (to_list x) k
|
||||
|
||||
let of_list l = List.fold add l empty
|
||||
|
||||
let to_array s = Array.of_list (to_list s)
|
||||
|
||||
let trychoose s = try Some (choose s) with Not_found -> None
|
||||
|
||||
let next elt s =
|
||||
let _below, present, above = split elt s in
|
||||
assert present ;
|
||||
min_elt above
|
||||
|
||||
let rec fold_pairs fn xs a =
|
||||
try
|
||||
let x = choose xs in
|
||||
let xs = remove x xs in
|
||||
fold (fn x) xs (fold_pairs fn xs a)
|
||||
with
|
||||
Not_found -> a
|
||||
|
||||
let fold_product fn xs ys =
|
||||
fold (fun x -> fold (fun y -> fn x y) ys) xs
|
||||
|
||||
let the_only p s =
|
||||
match filter p s with
|
||||
| s' when cardinal s' = 1 -> Some (choose s')
|
||||
| _ -> None
|
||||
|
||||
(* exception TakeFound of elt *)
|
||||
|
||||
(* let take p s = *)
|
||||
(* try iter (fun x -> if p x then raise (TakeFound(x))) s ; None *)
|
||||
(* with TakeFound(x) -> Some(x) *)
|
||||
|
||||
let rec take_first_pair fn s =
|
||||
try
|
||||
let x = choose s in
|
||||
let s = remove x s in
|
||||
match
|
||||
fold (fun y found ->
|
||||
match found with
|
||||
| None ->
|
||||
(match fn x y with
|
||||
| None -> fn y x
|
||||
| z -> z)
|
||||
| some -> some
|
||||
) s None
|
||||
with
|
||||
| None -> take_first_pair fn s
|
||||
| a -> a
|
||||
with
|
||||
Not_found -> None
|
||||
|
||||
let fold2 fn a s t = List.fold_left2 fn a (to_list s) (to_list t)
|
||||
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Sets of ordered values. See also standard
|
||||
{{:file:../../../doc/ocaml%20manual/libref/Set.html}Set}. *)
|
||||
module PolySet : sig
|
||||
module type S = sig
|
||||
type 'a elt
|
||||
type 'a t
|
||||
val empty : 'a t
|
||||
val is_empty : 'a t -> bool
|
||||
val add : 'a elt -> 'a t -> 'a t
|
||||
val singleton : 'a elt -> 'a t
|
||||
val iter : ('a elt -> unit) -> 'a t -> unit
|
||||
val map : ('a elt -> 'a elt) -> 'a t -> 'a t
|
||||
val fold : ('a elt -> 'z -> 'z) -> 'a t -> 'z -> 'z
|
||||
val exists : ('a elt -> bool) -> 'a t -> bool
|
||||
val filter : ('a elt -> bool) -> 'a t -> 'a t
|
||||
val mem : 'a elt -> 'a t -> bool
|
||||
val remove : 'a elt -> 'a t -> 'a t
|
||||
val union : 'a t -> 'a t -> 'a t
|
||||
val unions : 'a t list -> 'a t
|
||||
val inter : 'a t -> 'a t -> 'a t
|
||||
val inters : 'a t list -> 'a t
|
||||
val diff : 'a t -> 'a t -> 'a t
|
||||
val diff_diff : 'a t -> 'a t -> 'a t * 'a t
|
||||
val inter_diff : 'a t -> 'a t -> 'a t * 'a t
|
||||
val diff_inter_diff : 'a t -> 'a t -> 'a t * 'a t * 'a t
|
||||
val subset : 'a t -> 'a t -> bool
|
||||
val disjoint : 'a t -> 'a t -> bool
|
||||
val intersect : 'a t -> 'a t -> bool
|
||||
val kfold : 'a t -> ('a elt -> ('y->'z) -> 'y->'z) -> ('y->'z) -> 'y->'z
|
||||
val fold2 : ('z -> 'a elt -> 'a elt -> 'z) -> 'z -> 'a t -> 'a t -> 'z
|
||||
val for_all : ('a elt -> bool) -> 'a t -> bool
|
||||
val partition : ('a elt -> bool) -> 'a t -> 'a t * 'a t
|
||||
val cardinal : 'a t -> int
|
||||
val to_list : 'a t -> 'a elt list
|
||||
val of_list : 'a elt list -> 'a t
|
||||
val to_array : 'a t -> 'a elt array
|
||||
val min_elt : 'a t -> 'a elt
|
||||
val max_elt : 'a t -> 'a elt
|
||||
val choose : 'a t -> 'a elt
|
||||
val trychoose : 'a t -> 'a elt option
|
||||
val split : 'a elt -> 'a t -> 'a t * bool * 'a t
|
||||
val next : 'a elt -> 'a t -> 'a elt
|
||||
val fold_pairs : ('a elt -> 'a elt -> 'z -> 'z) -> 'a t -> 'z -> 'z
|
||||
val fold_product : ('a elt -> 'a elt -> 'z->'z) -> 'a t -> 'a t -> 'z->'z
|
||||
val the_only : ('a elt -> bool) -> 'a t -> 'a elt option
|
||||
(* val take : ('a elt -> bool) -> 'a t -> 'a elt option *)
|
||||
val take_first_pair : ('a elt -> 'a elt -> 'z option) -> 'a t -> 'z option
|
||||
val equal : 'a t -> 'a t -> bool
|
||||
val compare : 'a t -> 'a t -> int
|
||||
end
|
||||
|
||||
module Make (Ord : PolySet.OrderedType) : (S with type 'a elt = 'a Ord.t)
|
||||
end
|
||||
|
|
@ -0,0 +1,313 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
open NSList
|
||||
open NSOption
|
||||
|
||||
|
||||
module Set = struct
|
||||
module type Q = sig
|
||||
type elt
|
||||
type t
|
||||
val is_empty : t -> bool
|
||||
val mem : elt -> t -> bool
|
||||
val compare : t -> t -> int
|
||||
val equal : t -> t -> bool
|
||||
val subset : t -> t -> bool
|
||||
val disjoint : t -> t -> bool
|
||||
val intersect : t -> t -> bool
|
||||
val iter : (elt -> unit) -> t -> unit
|
||||
val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val foldr : (elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val foldi : (int -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_pairs : (elt -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_product : (elt -> elt -> 'a -> 'a) -> t -> t -> 'a -> 'a
|
||||
val fold2 : ('a -> elt -> elt -> 'a) -> 'a -> t -> t -> 'a
|
||||
val kfold : t -> (elt -> ('a->'b) -> 'a->'b) -> ('a->'b) -> 'a->'b
|
||||
val reduce : (elt -> 'a) -> (elt -> 'a -> 'a) -> t -> 'a option
|
||||
val for_all : (elt -> bool) -> t -> bool
|
||||
val exists : (elt -> bool) -> t -> bool
|
||||
val exists_unique : (elt -> bool) -> t -> bool
|
||||
val cardinal : t -> int
|
||||
val to_list : t -> elt list
|
||||
val to_array : t -> elt array
|
||||
val min_elt : t -> elt
|
||||
val max_elt : t -> elt
|
||||
val next : elt -> t -> elt
|
||||
val choose : t -> elt
|
||||
val trychoose : t -> elt option
|
||||
val extract : t -> elt * t
|
||||
val tryextract : t -> (elt * t) option
|
||||
val take : (elt -> bool) -> t -> elt
|
||||
val trytake : (elt -> bool) -> t -> elt option
|
||||
val take_first_pair : (elt -> elt -> 'a option) -> t -> 'a option
|
||||
val the_only : (elt -> bool) -> t -> elt option
|
||||
val classify : (elt -> elt -> bool) -> t -> elt list list
|
||||
end
|
||||
module type R = sig
|
||||
include Q
|
||||
val add : elt -> t -> t
|
||||
val adds : elt list -> t -> t
|
||||
val singleton : elt -> t
|
||||
val of_list : elt list -> t
|
||||
val remove : elt -> t -> t
|
||||
val union : t -> t -> t
|
||||
val unions : t list -> t
|
||||
val inter : t -> t -> t
|
||||
val inters : t list -> t
|
||||
val diff : t -> t -> t
|
||||
val diff_inter_diff : t -> t -> t * t * t
|
||||
val diff_diff : t -> t -> t * t
|
||||
val inter_diff : t -> t -> t * t
|
||||
val map : (elt -> elt) -> t -> t
|
||||
val map_fold : (elt * 'z -> elt * 'z) -> t * 'z -> t * 'z
|
||||
val map_foldi : (int -> elt * 'z -> elt * 'z) -> t * 'z -> t * 'z
|
||||
val filter : (elt -> bool) -> t -> t
|
||||
val partition : (elt -> bool) -> t -> t * t
|
||||
val split : elt -> t -> t * bool * t
|
||||
end
|
||||
module type S = sig
|
||||
include R
|
||||
val empty : t
|
||||
end
|
||||
|
||||
module Make (Ord: OrderedType) = struct
|
||||
include Set.Make(Ord)
|
||||
|
||||
let equal x y = if x == y then true else 0 = compare x y
|
||||
|
||||
let union x y = if x == y then x else union x y
|
||||
|
||||
let unions = List.fold_left union empty
|
||||
let inters = function
|
||||
| [] -> empty
|
||||
| xs::xss -> List.fold_left inter xs xss
|
||||
|
||||
let diff_inter_diff s t = let i = inter s t in (diff s i, i, diff t i)
|
||||
(* fold (fun a ((s_m_i,i,t_m_i) as acc) -> *)
|
||||
(* if mem a t *)
|
||||
(* then (remove a s_m_i, add a i, remove a t_m_i) *)
|
||||
(* else acc) *)
|
||||
(* s (s,empty,t) *)
|
||||
|
||||
let inter_diff x y = (inter x y, diff x y)
|
||||
let diff_diff x y = let (x_i, _, y_i) = diff_inter_diff x y in (x_i, y_i)
|
||||
|
||||
let disjoint x y = is_empty (inter x y)
|
||||
|
||||
(* Within the implementation of Set, the following implementation (due to
|
||||
Christophe Raffalli [christophe.raffalli@univ-savoie.fr]) should be
|
||||
faster:
|
||||
let rec disjoint t1 t2 =
|
||||
match (t1, t2) with
|
||||
(Empty, _) | (_, Empty) ->
|
||||
true
|
||||
| (Node (l1, v1, r1, _), Node (l2, v2, r2, _)) ->
|
||||
let c = Ord.compare v1 v2 in
|
||||
if c = 0 then
|
||||
false
|
||||
else if c < 0 then
|
||||
disjoint (Node (l1, v1, Empty, 0)) l2 && disjoint r1 t2
|
||||
else
|
||||
disjoint l1 (Node (l2, v2, Empty, 0)) && disjoint t1 r2
|
||||
*)
|
||||
|
||||
let intersect x y = not (disjoint x y)
|
||||
|
||||
let to_list = elements
|
||||
|
||||
let map fn s = fold (fun kv t -> add (fn kv) t) s empty
|
||||
|
||||
let foldr fn s = List.fold_right fn (to_list s)
|
||||
|
||||
let foldi fn s z = snd (fold (fun x (i,z) -> (i+1, fn i x z)) s (0, z))
|
||||
|
||||
let kfold x fn k = List.kfold fn (to_list x) k
|
||||
|
||||
let map_fold fn (s,z) =
|
||||
fold (fun x (s',z) ->
|
||||
let x', z' = fn (x, z) in
|
||||
(add x' s', z')
|
||||
) s (empty, z)
|
||||
|
||||
let map_foldi fn (s,z) =
|
||||
foldi (fun i x (s',z) ->
|
||||
let x', z' = fn i (x, z) in
|
||||
(add x' s', z')
|
||||
) s (empty, z)
|
||||
|
||||
let of_list l = List.fold add l empty
|
||||
|
||||
let adds l s = List.fold add l s
|
||||
|
||||
let to_array s = Array.of_list (to_list s)
|
||||
|
||||
let trychoose s = try Some (choose s) with Not_found -> None
|
||||
|
||||
let next elt s =
|
||||
let _below, present, above = split elt s in
|
||||
assert present ;
|
||||
min_elt above
|
||||
|
||||
let rec fold_pairs fn xs a =
|
||||
try
|
||||
let x = choose xs in
|
||||
let xs = remove x xs in
|
||||
fold (fun a -> fn x a) xs (fold_pairs fn xs a)
|
||||
with
|
||||
Not_found -> a
|
||||
|
||||
let fold_product fn xs ys z =
|
||||
fold (fun x z -> fold (fun y z -> fn x y z) ys z) xs z
|
||||
|
||||
let the_only p s =
|
||||
match filter p s with
|
||||
| s' when cardinal s' = 1 -> Some (choose s')
|
||||
| _ -> None
|
||||
|
||||
(* Note: should be implemented with one search *)
|
||||
let extract xs =
|
||||
let x = choose xs in
|
||||
(x, remove x xs)
|
||||
|
||||
let tryextract xs =
|
||||
try Some(extract xs) with Not_found -> None
|
||||
|
||||
exception TakeFound of elt
|
||||
|
||||
let take p s =
|
||||
try iter (fun x -> if p x then raise (TakeFound(x))) s ; raise Not_found
|
||||
with TakeFound(x) -> x
|
||||
|
||||
let trytake p s =
|
||||
try Some(take p s) with Not_found -> None
|
||||
|
||||
let rec take_first_pair fn s =
|
||||
try
|
||||
let x = choose s in
|
||||
let s = remove x s in
|
||||
match
|
||||
fold (fun y found ->
|
||||
match found with
|
||||
| None ->
|
||||
(match fn x y with
|
||||
| None -> fn y x
|
||||
| z -> z)
|
||||
| some -> some
|
||||
) s None
|
||||
with
|
||||
| None -> take_first_pair fn s
|
||||
| a -> a
|
||||
with
|
||||
Not_found -> None
|
||||
|
||||
let fold2 fn a s t = List.fold_left2 fn a (to_list s) (to_list t)
|
||||
|
||||
let exists_unique p xs =
|
||||
let module M = struct exception Found end in
|
||||
try
|
||||
fold (fun x found ->
|
||||
if found
|
||||
then not (p x) || raise M.Found
|
||||
else p x
|
||||
) xs false
|
||||
with M.Found -> false
|
||||
|
||||
let reduce init fn xs =
|
||||
tryextract xs
|
||||
>>== fun (x, xs) -> fold fn xs (init x)
|
||||
|
||||
let classify fn xs =
|
||||
let rec classify_one x = function
|
||||
| xs :: xss when fn x (List.hd xs) -> (x :: xs) :: xss
|
||||
| xs :: xss -> xs :: (classify_one x xss)
|
||||
| [] -> [[x]]
|
||||
in
|
||||
fold classify_one xs []
|
||||
|
||||
end
|
||||
|
||||
|
||||
module type EmbedProject = sig
|
||||
type t
|
||||
type s
|
||||
val embed : s -> t -> t
|
||||
val project : t -> s
|
||||
end
|
||||
|
||||
module Lift (S: S) (EP: EmbedProject with type s = S.t) : sig
|
||||
include S with type elt = S.elt and type t = EP.t
|
||||
val empty : t -> t
|
||||
end = struct
|
||||
|
||||
type elt = S.elt
|
||||
type t = EP.t
|
||||
|
||||
let is_empty x = S.is_empty (EP.project x)
|
||||
let mem e x = S.mem e (EP.project x)
|
||||
let compare _ = failwith "ToDo: NSSet.Lift.compare"
|
||||
let equal _ = failwith "ToDo: NSSet.Lift.equal"
|
||||
let subset _ = failwith "ToDo: NSSet.Lift.subset"
|
||||
let disjoint _ = failwith "ToDo: NSSet.Lift.disjoint"
|
||||
let intersect _ = failwith "ToDo: NSSet.Lift.intersect"
|
||||
let iter _ = failwith "ToDo: NSSet.Lift.iter"
|
||||
let fold f x z = S.fold f (EP.project x) z
|
||||
let foldr _ = failwith "ToDo: NSSet.Lift.foldr"
|
||||
let foldi f x z = S.foldi f (EP.project x) z
|
||||
let fold_pairs _ = failwith "ToDo: NSSet.Lift.fold_pairs"
|
||||
let fold_product _ = failwith "ToDo: NSSet.Lift.fold_product"
|
||||
let fold2 _ = failwith "ToDo: NSSet.Lift.fold2"
|
||||
let kfold x f k z = S.kfold (EP.project x) f k z
|
||||
let for_all _ = failwith "ToDo: NSSet.Lift.for_all"
|
||||
let exists _ = failwith "ToDo: NSSet.Lift.exists"
|
||||
let exists_unique _ = failwith "ToDo: NSSet.Lift.exists_unique"
|
||||
let cardinal x = S.cardinal (EP.project x)
|
||||
let to_list _ = failwith "ToDo: NSSet.Lift.to_list"
|
||||
let to_array _ = failwith "ToDo: NSSet.Lift.to_array"
|
||||
let min_elt _ = failwith "ToDo: NSSet.Lift.min_elt"
|
||||
let max_elt _ = failwith "ToDo: NSSet.Lift.max_elt"
|
||||
let next _ = failwith "ToDo: NSSet.Lift.next"
|
||||
let choose x = S.choose (EP.project x)
|
||||
let trychoose x = S.trychoose (EP.project x)
|
||||
let extract _ = failwith "ToDo: NSSet.Lift.extract"
|
||||
let tryextract _ = failwith "ToDo: NSSet.Lift.tryextract"
|
||||
let take _ _ = failwith "ToDo: NSSet.Lift.take"
|
||||
|
||||
let trytake p s =
|
||||
try Some(take p s) with Not_found -> None
|
||||
|
||||
let take_first_pair _ = failwith "ToDo: NSSet.Lift.take_first_pair"
|
||||
let the_only _ = failwith "ToDo: NSSet.Lift.the_only"
|
||||
let reduce _ = failwith "ToDo: NSSet.Lift.reduce"
|
||||
let classify _ = failwith "ToDo: NSSet.Lift.classify"
|
||||
let add e x = EP.embed (S.add e (EP.project x)) x
|
||||
let adds l x = EP.embed (S.adds l (EP.project x)) x
|
||||
let singleton _ = failwith "ToDo: NSSet.Lift.singleton"
|
||||
let of_list _ = failwith "ToDo: NSSet.Lift.of_list"
|
||||
let remove e x = EP.embed (S.remove e (EP.project x)) x
|
||||
let union _ = failwith "ToDo: NSSet.Lift.union"
|
||||
let unions _ = failwith "ToDo: NSSet.Lift.unions"
|
||||
let inter _ = failwith "ToDo: NSSet.Lift.inter"
|
||||
let inters _ = failwith "ToDo: NSSet.Lift.inters"
|
||||
let diff _ = failwith "ToDo: NSSet.Lift.diff"
|
||||
let diff_inter_diff _ = failwith "ToDo: NSSet.Lift.diff_inter_diff"
|
||||
let diff_diff _ = failwith "ToDo: NSSet.Lift.diff_diff"
|
||||
let inter_diff _ = failwith "ToDo: NSSet.Lift.inter_diff"
|
||||
let map f x = EP.embed (S.map f (EP.project x)) x
|
||||
let map_fold _ = failwith "ToDo: NSSet.Lift.map_fold"
|
||||
let map_foldi _ = failwith "ToDo: NSSet.Lift.map_foldi"
|
||||
let filter p x = EP.embed (S.filter p (EP.project x)) x
|
||||
let partition _ = failwith "ToDo: NSSet.Lift.partition"
|
||||
let split _ = failwith "ToDo: NSSet.Lift.split"
|
||||
let empty x = EP.embed S.empty x
|
||||
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
|
||||
module IntSet = Set.Make(struct
|
||||
type t = int
|
||||
let compare = (Pervasives.compare : int -> int -> int)
|
||||
let equal = (Pervasives.( = ) : int -> int -> bool)
|
||||
end)
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
open NSLib
|
||||
|
||||
|
||||
(** Sets of ordered values. See also standard
|
||||
{{:file:../../../doc/ocaml%20manual/libref/Set.html}Set}. *)
|
||||
module Set : sig
|
||||
module type Q = sig
|
||||
type elt
|
||||
type t
|
||||
val is_empty : t -> bool
|
||||
val mem : elt -> t -> bool
|
||||
val compare : t -> t -> int
|
||||
val equal : t -> t -> bool
|
||||
val subset : t -> t -> bool
|
||||
val disjoint : t -> t -> bool
|
||||
val intersect : t -> t -> bool
|
||||
val iter : (elt -> unit) -> t -> unit
|
||||
val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val foldr : (elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val foldi : (int -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_pairs : (elt -> elt -> 'a -> 'a) -> t -> 'a -> 'a
|
||||
val fold_product : (elt -> elt -> 'a -> 'a) -> t -> t -> 'a -> 'a
|
||||
val fold2 : ('a -> elt -> elt -> 'a) -> 'a -> t -> t -> 'a
|
||||
val kfold : t -> (elt -> ('a->'b) -> 'a->'b) -> ('a->'b) -> 'a->'b
|
||||
val reduce : (elt -> 'a) -> (elt -> 'a -> 'a) -> t -> 'a option
|
||||
val for_all : (elt -> bool) -> t -> bool
|
||||
val exists : (elt -> bool) -> t -> bool
|
||||
val exists_unique : (elt -> bool) -> t -> bool
|
||||
val cardinal : t -> int
|
||||
val to_list : t -> elt list
|
||||
val to_array : t -> elt array
|
||||
val min_elt : t -> elt
|
||||
val max_elt : t -> elt
|
||||
val next : elt -> t -> elt
|
||||
val choose : t -> elt
|
||||
val trychoose : t -> elt option
|
||||
val extract : t -> elt * t
|
||||
val tryextract : t -> (elt * t) option
|
||||
val take : (elt -> bool) -> t -> elt
|
||||
val trytake : (elt -> bool) -> t -> elt option
|
||||
val take_first_pair : (elt -> elt -> 'a option) -> t -> 'a option
|
||||
val the_only : (elt -> bool) -> t -> elt option
|
||||
val classify : (elt -> elt -> bool) -> t -> elt list list
|
||||
end
|
||||
module type R = sig
|
||||
include Q
|
||||
val add : elt -> t -> t
|
||||
val adds : elt list -> t -> t
|
||||
val singleton : elt -> t
|
||||
val of_list : elt list -> t
|
||||
val remove : elt -> t -> t
|
||||
val union : t -> t -> t
|
||||
val unions : t list -> t
|
||||
val inter : t -> t -> t
|
||||
val inters : t list -> t
|
||||
val diff : t -> t -> t
|
||||
val diff_inter_diff : t -> t -> t * t * t
|
||||
val diff_diff : t -> t -> t * t
|
||||
val inter_diff : t -> t -> t * t
|
||||
val map : (elt -> elt) -> t -> t
|
||||
val map_fold : (elt * 'z -> elt * 'z) -> t * 'z -> t * 'z
|
||||
val map_foldi : (int -> elt * 'z -> elt * 'z) -> t * 'z -> t * 'z
|
||||
val filter : (elt -> bool) -> t -> t
|
||||
val partition : (elt -> bool) -> t -> t * t
|
||||
val split : elt -> t -> t * bool * t
|
||||
end
|
||||
module type S = sig
|
||||
include R
|
||||
val empty : t
|
||||
end
|
||||
|
||||
module Make (Ord : OrderedType) : (S with type elt = Ord.t)
|
||||
|
||||
module type EmbedProject = sig
|
||||
type t
|
||||
type s
|
||||
val embed : s -> t -> t
|
||||
val project : t -> s
|
||||
end
|
||||
|
||||
module Lift (S: S) (EP: EmbedProject with type s = S.t) : sig
|
||||
include S with type elt = S.elt and type t = EP.t
|
||||
val empty : t -> t
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
|
||||
module IntSet : Set.S with type elt = int
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
|
||||
module SortedList = struct
|
||||
|
||||
let rec is_sorted cmp = function
|
||||
| [] | [_] -> true
|
||||
| x :: (y :: _ as yzs) -> cmp x y <= 0 && is_sorted cmp yzs
|
||||
|
||||
let check_sorted cmp xs = assert( is_sorted cmp xs ); xs
|
||||
|
||||
let sort cmp x = List.fast_sort cmp x
|
||||
|
||||
let rec add cmp x = function
|
||||
| [] -> [x]
|
||||
| y :: ys as yys ->
|
||||
let ord = cmp x y in
|
||||
if ord < 0 then x :: yys
|
||||
else if ord = 0 then yys
|
||||
else (* ord > 0 *) y :: add cmp x ys
|
||||
|
||||
let rec merge cmp cons bbs0 bbs1 =
|
||||
match bbs0, bbs1 with
|
||||
| [] , bbs1 -> bbs1
|
||||
| bbs0 , [] -> bbs0
|
||||
| b0 :: bs0, b1 :: bs1 ->
|
||||
let ord = cmp b0 b1 in
|
||||
if ord <= 0 then cons b0 (merge cmp cons bs0 bbs1)
|
||||
else (* ord > 0 *) cons b1 (merge cmp cons bbs0 bs1)
|
||||
|
||||
let rec union cmp cons bbs0 bbs1 =
|
||||
match bbs0, bbs1 with
|
||||
| [] , bbs1 -> bbs1
|
||||
| bbs0 , [] -> bbs0
|
||||
| b0 :: bs0, b1 :: bs1 ->
|
||||
let ord = cmp b0 b1 in
|
||||
if ord < 0 then cons b0 (union cmp cons bs0 bbs1)
|
||||
else if ord = 0 then union cmp cons bs0 bbs1
|
||||
else (* ord > 0 *) cons b1 (union cmp cons bbs0 bs1)
|
||||
|
||||
let rec inter cmp xxs yys =
|
||||
match xxs, yys with
|
||||
| [] , _ -> []
|
||||
| _ , [] -> []
|
||||
| x::xs, y::ys ->
|
||||
match cmp x y with
|
||||
| n when n < 0 -> inter cmp xs yys
|
||||
| 0 -> x :: (inter cmp xs ys)
|
||||
| _ -> inter cmp xxs ys
|
||||
|
||||
let rec intersect cmp xxs yys =
|
||||
match xxs, yys with
|
||||
| [] , _ -> false
|
||||
| _ , [] -> false
|
||||
| x::xs, y::ys ->
|
||||
match cmp x y with
|
||||
| n when n < 0 -> intersect cmp xs yys
|
||||
| 0 -> true
|
||||
| _ -> intersect cmp xxs ys
|
||||
|
||||
let rec diff cmp xxs yys =
|
||||
match xxs, yys with
|
||||
| [] , _ -> []
|
||||
| _ , [] -> xxs
|
||||
| x::xs, y::ys ->
|
||||
match cmp x y with
|
||||
| n when n < 0 -> x :: diff cmp xs yys
|
||||
| 0 -> diff cmp xs ys
|
||||
| _ -> diff cmp xxs ys
|
||||
|
||||
let rec diff_inter_diff cmp xxs yys =
|
||||
match xxs, yys with
|
||||
| [] , [] -> ([], [], [])
|
||||
| [] , _ -> ([], [], yys)
|
||||
| _ , [] -> (xxs, [], [])
|
||||
| x::xs, y::ys ->
|
||||
match cmp x y with
|
||||
| n when n < 0 ->
|
||||
let xs_yys, is, yys_xs = diff_inter_diff cmp xs yys in
|
||||
(x::xs_yys, is, yys_xs)
|
||||
| 0 ->
|
||||
let xs_ys, is, ys_xs = diff_inter_diff cmp xs ys in
|
||||
(xs_ys, x::is, ys_xs)
|
||||
| _ ->
|
||||
let xxs_ys, is, ys_xxs = diff_inter_diff cmp xxs ys in
|
||||
(xxs_ys, is, y::ys_xxs)
|
||||
|
||||
let rec mem cmp x = function
|
||||
| [] -> false
|
||||
| y :: xs ->
|
||||
match cmp x y with
|
||||
| n when n < 0 -> false
|
||||
| 0 -> true
|
||||
| _ -> mem cmp x xs
|
||||
|
||||
let rec subsupset cmp xxs yys =
|
||||
match xxs, yys with
|
||||
| [] , [] -> (true, true)
|
||||
| _::_ , [] -> (false, true)
|
||||
| [] , _::_ -> (true, false)
|
||||
| x::xs, y::ys ->
|
||||
match cmp x y with
|
||||
| n when n < 0 -> (false, snd (subsupset cmp xs yys))
|
||||
| 0 -> subsupset cmp xs ys
|
||||
| _ -> (fst (subsupset cmp xxs ys), false)
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
|
||||
(** Operations on sorted ['a list]. *)
|
||||
module SortedList : sig
|
||||
val is_sorted : ('a->'a->int)-> 'a list -> bool
|
||||
val check_sorted : ('a->'a->int)-> 'a list -> 'a list
|
||||
|
||||
(** Construct a SortedList from an unsorted list. *)
|
||||
val sort : ('a->'a->int)-> 'a list -> 'a list
|
||||
|
||||
(** Adds an element into a sorted list, if it is not already a member. *)
|
||||
val add : ('a->'a->int)-> 'a -> 'a list -> 'a list
|
||||
|
||||
(** Merges two sorted lists using given addition operation, keeping
|
||||
duplicates. *)
|
||||
val merge : ('a->'a->int)->
|
||||
('a -> 'a list -> 'a list) -> 'a list -> 'a list -> 'a list
|
||||
|
||||
(** Unions two sorted lists using given addition operation. *)
|
||||
val union : ('a->'a->int)->
|
||||
('a -> 'a list -> 'a list) -> 'a list -> 'a list -> 'a list
|
||||
|
||||
val inter : ('a->'a->int)-> 'a list -> 'a list -> 'a list
|
||||
|
||||
val diff : ('a->'a->int)-> 'a list -> 'a list -> 'a list
|
||||
|
||||
val intersect : ('a->'a->int)-> 'a list -> 'a list -> bool
|
||||
|
||||
val diff_inter_diff : ('a->'a->int)->
|
||||
'a list -> 'a list -> 'a list * 'a list * 'a list
|
||||
|
||||
val mem : ('a->'a->int)-> 'a -> 'a list -> bool
|
||||
|
||||
(** Takes two sorted lists [xs], [ys] and returns a pair of booleans
|
||||
indicating whether [xs] is a subset of [ys], and whether [xs] is a
|
||||
superset of [ys]. *)
|
||||
val subsupset : ('a->'a->int)-> 'a list -> 'a list -> bool * bool
|
||||
end
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
(* Copyright (c) Microsoft Corporation. All rights reserved. *)
|
||||
|
||||
|
||||
module String = struct
|
||||
include String
|
||||
|
||||
let filteri fn s =
|
||||
let len = length s in
|
||||
let s' = create len in
|
||||
let start = ref (-1) in
|
||||
let count = ref 0 in
|
||||
for i = 0 to len - 1 do
|
||||
if fn i s.[i] then (
|
||||
s'.[!count] <- s.[i] ;
|
||||
incr count ;
|
||||
if !start < 0 then start := i ;
|
||||
)
|
||||
done ;
|
||||
if !start < 0 then start := 0 ;
|
||||
sub s' !start !count
|
||||
|
||||
end
|
||||
Некоторые файлы не были показаны из-за слишком большого количества измененных файлов Показать больше
Загрузка…
Ссылка в новой задаче