commit ee2456350990f9990758cbaf631bb6359007b90e Author: Samin Ishtiaq Date: Fri Feb 26 15:39:53 2016 +0000 fr original repo diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 0000000..ae8e8ca --- /dev/null +++ b/.ocp-indent @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5298a4e --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..b87680c --- /dev/null +++ b/README.md @@ -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. + diff --git a/config.cmd b/config.cmd new file mode 100644 index 0000000..9d2abd6 --- /dev/null +++ b/config.cmd @@ -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 diff --git a/config.sh b/config.sh new file mode 100644 index 0000000..c7d66e4 --- /dev/null +++ b/config.sh @@ -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" diff --git a/include/slayer.h b/include/slayer.h new file mode 100644 index 0000000..f0eafbc --- /dev/null +++ b/include/slayer.h @@ -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 +#include + +/* 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_ diff --git a/include/slayer_intrinsics.h b/include/slayer_intrinsics.h new file mode 100644 index 0000000..7464550 --- /dev/null +++ b/include/slayer_intrinsics.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_ diff --git a/src/.ocamlspot b/src/.ocamlspot new file mode 100644 index 0000000..db91402 --- /dev/null +++ b/src/.ocamlspot @@ -0,0 +1 @@ +build_dir=_build diff --git a/src/AbstractTransitionSystem.ml b/src/AbstractTransitionSystem.ml new file mode 100644 index 0000000..5edc2bf --- /dev/null +++ b/src/AbstractTransitionSystem.ml @@ -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 "@[%a@ @[%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 "@[%a;@]" (List.fmt ";@ " I.fmt) blk + in + let fmt_blk_pos ff blk = + let fmt_pos_inst ff {I.desc; pos} = + Format.fprintf ff "@[%a:@ %a@]" Position.fmt pos I.fmt_desc desc in + Format.fprintf ff "@[%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 "@[%( fmt %)@]" leak + | 1 -> Format.fprintf ff "@[%( fmt %)%a@]" leak fmt_assumes b + | 2 -> Format.fprintf ff "@[%( fmt %)%a@]" leak fmt_blk b + | _ -> Format.fprintf ff "@[%( 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 "@[%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@[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@[adding transition:@\n@[%a@]@ @[from@ %a@]@ @[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 "@[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@[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 diff --git a/src/AbstractTransitionSystem.mli b/src/AbstractTransitionSystem.mli new file mode 100644 index 0000000..37efe22 --- /dev/null +++ b/src/AbstractTransitionSystem.mli @@ -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 diff --git a/src/Abstraction.ml b/src/Abstraction.ml new file mode 100644 index 0000000..641f816 --- /dev/null +++ b/src/Abstraction.ml @@ -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 "@[%sreplace:@ %t@]@ @[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: @[{%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@[(* abstract:@ %a@]@\n*)@\n\ + @[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) diff --git a/src/Abstraction.mli b/src/Abstraction.mli new file mode 100644 index 0000000..02d06d5 --- /dev/null +++ b/src/Abstraction.mli @@ -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 diff --git a/src/Analysis.ml b/src/Analysis.ml new file mode 100644 index 0000000..1575297 --- /dev/null +++ b/src/Analysis.ml @@ -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 "@[%a%a@]" + (Vars.fmt_embrace "@[! " " .@]@ ") 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 diff --git a/src/Analysis.mli b/src/Analysis.mli new file mode 100644 index 0000000..2d97b46 --- /dev/null +++ b/src/Analysis.mli @@ -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 diff --git a/src/BiEdge.ml b/src/BiEdge.ml new file mode 100644 index 0000000..adf809c --- /dev/null +++ b/src/BiEdge.ml @@ -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 + "@[@[@[%a@],@ @[%a@]@],@ @[@[%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 diff --git a/src/BiEdge.mli b/src/BiEdge.mli new file mode 100644 index 0000000..eedb13d --- /dev/null +++ b/src/BiEdge.mli @@ -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) diff --git a/src/CONGRUENCE_RELATION.ml b/src/CONGRUENCE_RELATION.ml new file mode 100644 index 0000000..442737e --- /dev/null +++ b/src/CONGRUENCE_RELATION.ml @@ -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 diff --git a/src/CngRel.ml b/src/CngRel.ml new file mode 100644 index 0000000..021a592 --- /dev/null +++ b/src/CngRel.ml @@ -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 "@[{@[%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 "@[{@[%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 "@[{@[%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 "@[[@[%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 "@[%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 + "@[{@[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:@ @[%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:@ @[%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) *) diff --git a/src/CngRel.mli b/src/CngRel.mli new file mode 100644 index 0000000..22ae420 --- /dev/null +++ b/src/CngRel.mli @@ -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 diff --git a/src/Config.ml b/src/Config.ml new file mode 100644 index 0000000..4054701 --- /dev/null +++ b/src/Config.ml @@ -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), + " Optimize: Frame \ + (default="^ (string_of_bool !optimize_frame) ^")"); + ("-generalize-call-retn", Arg.Bool (fun x -> generalize_call_retn := x), + " Generalize assertions at procedure call and return sites \ + (default="^ (string_of_bool !generalize_call_retn) ^")"); + ("-join-powerset", Arg.Bool (fun x -> join_powerset := x), + " Use powerset join instead of constructing disjunctive formulae \ + (default="^ (string_of_bool !join_powerset) ^")"); + ("-limit", Arg.Set_int limit, + " 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), + " Preserve facts about program constants \ + (default="^ (string_of_bool !preserve_consts) ^")"); + ("-trust-casts", Arg.Bool (fun x -> trust_casts := x), + " 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), + " Show unreachable states in the abstract transition system \ + (default="^(string_of_bool !show_unreachable)^")"); + ("-ATS-reduce", Arg.Set_int join_reduce, + " 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, + " The right margin used by the pretty printer \ + (default="^ (string_of_int !margin) ^")"); + ("-margin-frac", Arg.Set_float margin_frac, + " The target columns/lines fraction of pretty printed graph vertices \ + (default="^ (string_of_float !margin_frac) ^")"); + ("-font", Arg.Set_string font, + " The font used in dot graphs \ + (default="^ !font ^")"); + + ("-vAbs", Arg.Set_int vAbs, " Verbosity of Abstraction module"); + ("-vAbsH", Arg.Set_int vAbsH, " Verbosity of HeapAbstraction module"); + ("-vATS", Arg.Set_int vATS, " Verbosity of AbstractTransistionSystem module"); + ("-vCEx", Arg.Set_int vCEx, " Verbosity of CounterExample module"); + ("-vCng", Arg.Set_int vCng, " Verbosity of CngRel module"); + ("-vDCC", Arg.Set_int vDCC, " Verbosity of DisjCngClos module"); + ("-vDiscovery", Arg.Set_int vDiscovery, " Verbosity of Discovery module"); + ("-vExp", Arg.Set_int vExp, " Verbosity of Expression module"); + ("-vFrame", Arg.Set_int vFrame, " Verbosity of Frame module"); + ("-vGraph", Arg.Set_int vGraph, " Verbosity of Graph module"); + ("-vHG", Arg.Set_int vHG, " Verbosity of HeapGraph module"); + ("-vInstr", Arg.Set_int vInstr, " Verbosity of Instrumentation module"); + ("-vPrv", Arg.Set_int vPrv, " Verbosity of Prover module"); + ("-vPure", Arg.Set_int vPure, " Verbosity of Pure module") ; + ("-vRch", Arg.Set_int vRch, " Verbosity of Reachability module"); + ("-vSE", Arg.Set_int vSE, " Verbosity of SymbolicExecution module"); + ("-vSH", Arg.Set_int vSH, " Verbosity of SymbolicHeap module"); + ("-vPgm", Arg.Set_int vPgm, " Verbosity of Program module"); + ("-vSubst", Arg.Set_int vSubst, " Verbosity of Substitution module"); + ("-vTr", Arg.Set_int vTr, " Verbosity of reporting ATS transitions (default="^ (string_of_int !vTr) ^")"); + ("-vTyp", Arg.Set_int vTyp, " Verbosity of Type module"); + ("-vVar", Arg.Set_int vVar, " Verbosity of Variable module"); + ("-vZ3", Arg.Set_int vZ3, " Verbosity of Z3 library") ; + + (* options that control internal behavior but should not meaningfully affect results *) + ("-DCC-gie", Arg.Bool (fun x -> dcc_gie := x), + " Call get_implied_equalities from DCC" + ^" (default="^(string_of_bool !dcc_gie)^")"); + + ("-Exp-simplify", Arg.Bool (fun x -> exp_simplify := x), + " Perform syntactic simplification of Expressions" + ^" (default="^(string_of_bool !exp_simplify)^")"); + ("-Exp-expand-ite", Arg.Bool (fun x -> exp_expand_ite := x), + " Expand if-then-else Expressions into disjunctions" + ^" (default="^(string_of_bool !exp_simplify)^")"); + ("-Exp-hc-size", Arg.Set_int exp_hc_initial_size, + " Initial size of table for hash-consing Expressions" + ^" (default="^(string_of_int !exp_hc_initial_size)^")"); + ("-Exp-compare", Arg.Int set_perm, + " 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), + " 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), + " 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), + " Compute existential witnesses using normalization \ + (default="^(string_of_bool !prv_wbn)^")"); + + ("-SH-distrib-pure", Arg.Bool (fun x -> distrib_pure := x), + " Distribute pure conjunction under disjunction \ + (default="^(string_of_bool !distrib_pure)^")"); + ("-SH-simplify", Arg.Bool (fun x -> sh_simplify := x), + " 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), + " 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, + " 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), + " Use 'distinct' formulas in Z3 encoding \ + (default="^ (string_of_bool !z3_distinct) ^")") ; + ("-Z3-quant-weight", Arg.Set_int quant_weight, + " Set the weight of quantifiers, used by Z3 \ + (default="^ (string_of_int !quant_weight) ^")") ; + ("-Z3-quant-inst", Arg.Bool (fun x -> z3_ematching := x), + " Use heuristic quantifier instantiation \ + (default="^ (string_of_bool !z3_ematching) ^")") ; + ("-Z3-relevancy", Arg.Set_int z3_relevancy, + " relevancy propagation heuristic \ + (default="^ (string_of_int !z3_relevancy) ^")") ; + ("-Z3-timeout", Arg.Set_int z3_timeout, + " Set a time limit (in milliseconds) for calls to Z3") ; + ("-Z3-memout", Arg.Set_int z3_memout, + " Set a memory limit (in megabytes) for calls to Z3") ; + ("-Z3-rf", Arg.Set_int reset_freq, + " Z3 context reset frequency (0=never) \ + (default="^ (string_of_int !reset_freq) ^")") ; + + ("-gie", Arg.Set_int gie, + " Select 'get_implied_equalities' algorithm \ + (default="^ (string_of_int !gie) ^")") ; + ("-gie-incremental", Arg.Bool (fun x -> gie_incremental := x), + " Manage assertions incrementally for 'get_implied_equalities' \ + (default="^ (string_of_bool !gie_incremental) ^")") ; + ("-gie-weak", Arg.Bool (fun x -> gie_weak := x), + " Use weak encoding for 'get_implied_equalities' \ + (default="^ (string_of_bool !gie_weak) ^")") ; + + ("-minor-heap-size", Arg.Set_int minor_heap_size, + " Initial minor heap size in MB \ + (default="^ (string_of_int !minor_heap_size) ^")") ; + + (* options for debugging *) + ("-checkCng", Arg.Bool (fun x -> check_cng := x), + " Perform expensive checking of CngRel operations \ + (default="^ (string_of_bool !check_cng) ^")"); + ("-checkGIE", Arg.Bool (fun x -> check_gie := x), + " Check soundness and completeness of get_implied_equalities \ + (default="^ (string_of_bool !check_gie) ^")") ; + ("-checkGIEvsCC", Arg.Bool (fun x -> check_gie_vs_cc := x), + " 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), + " Use prover to check soundness of abstraction \ + (default="^ (string_of_bool !check_abs) ^")"); + ("-checkPrv", Arg.Bool (fun x -> check_prv := x), + " Use prover to check its own soundness \ + (default="^ (string_of_bool !check_prv) ^")"); + ("-checkSorts", Arg.Bool (fun x -> check_sorts := x), + " Check well-sortedness \ + (default="^ (string_of_bool !check_sorts) ^")") ; + ("-checkSCC", Arg.Bool (fun x -> check_scc := x), + " 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, + " Generate standalone repro for Abstraction call number "); + ("-gtn", Arg.Set_int norm_query_to_gen, + " Generate repro for SymbolicHeap normalization"); + ("-gtp", Arg.Set_int prv_gen_test, + " Generate standalone test for Prover query number "); + + ("-show-models", Arg.Set z3_model, + " Display Z3 models") ; + ("-Z3-print-mode", Arg.Set_string z3_print_mode, + " Set Z3 printing mode: full, low, smt, smt2") ; + + ("-tca", Arg.Set_float check_assumptions_time, + " Report check_assumptions calls exceeding time. Negative for running max"); + ("-te", Arg.Set_float entails_time, + " Report entails calls exceeding time. Negative for running max"); + ("-ts", Arg.Set_float subtract_time, + " 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), + " 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, + " 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), + " Optimize: Constrain static approximation of indirect call targets using types \ + (default="^ (string_of_bool !optimize_icall_targets) ^")"); + ("-Oinline", Arg.Set_int optimize_inline, + " 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), + " Optimize: Only box address taken globals and global structs (default="^ + (string_of_bool !optimize_boxing) ^")"); + ("-Oliveness", Arg.Bool (fun x -> optimize_liveness := x), + " Optimize: Apply liveness transformations \ + (default="^ (string_of_bool !optimize_liveness) ^")"); + ("-Ounused", Arg.Bool (fun x -> optimize_unused := x), + " Optimize: Remove unused globals variables \ + (default="^ (string_of_bool !optimize_unused) ^")"); + ("-vFE", Arg.Set_int vFE, + " Verbosity of Frontend module"); + ("-vInline", Arg.Set_int vInline, + " Verbosity of Inline module"); + ("-vJoinPoint", Arg.Set_int vJoinPoint, + " Verbosity of JoinPoint module"); + ("-vLiveness", Arg.Set_int vLiveness, + " Verbosity of Liveness module"); +] + + +let _ = + let argspec = Arg.align !argspec + and anon_arg_func fname = filenames := fname :: !filenames + and usage = "Usage: "^Sys.argv.(0)^" {-version | .{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 ()) diff --git a/src/CounterExample.ml b/src/CounterExample.ml new file mode 100644 index 0000000..34d1fea --- /dev/null +++ b/src/CounterExample.ml @@ -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 "@[%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. *) + + (* "^(?[0-9]+)[ \\t\"]+(?[^\"]+)[ \\t\"]+(?[0-9]+)[ \\t]+(?[^ ]+)[ \\t]+(?[^ ]+)[ \\t]+Call[ \t]+\"(?[^\"]+)\"+[ \\t]+\"(?[^\"]+)\"[ \\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 + + (* "^(?[0-9]+)[ \\t\"]+(?[^\"]+)[ \\t\"]+(?[0-9]+)[ \\t]+(?[^ ]+)[ \\t]+(?[^ ]+)[ \\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) + + (* "^(?[0-9]+)[ \\t\"]+(?[^\"]+)[ \\t\"]+(?[0-9]+)[ \\t]+(?[^ ]+)[ \\t]+(?[^ ]+)[ \\t]+Atomic[ \\t]+(?[^ ]+)[ \\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\"]+)(?[^\"]+)[ \\t\"]*" *) + let write_driver ff driver = + Format.fprintf ff "Driver %a@\n" + fmt_str driver + + (* "^Rule[ \\t]+(?[^ ]+)[ \\t]*" *) + let write_rule ff rule = + Format.fprintf ff "Rule %a@\n" + fmt_str rule + + (* "^Error[ \\t]+(?.* )" *) + (* 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 "@[%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 diff --git a/src/CounterExample.mli b/src/CounterExample.mli new file mode 100644 index 0000000..50d173c --- /dev/null +++ b/src/CounterExample.mli @@ -0,0 +1,6 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Generation of counter-example trace for sdvdefect viewer *) + + +val disprove : Analysis.t -> bool diff --git a/src/Discovery.ml b/src/Discovery.ml new file mode 100644 index 0000000..769b195 --- /dev/null +++ b/src/Discovery.ml @@ -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 "@[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 "@[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) diff --git a/src/Discovery.mli b/src/Discovery.mli new file mode 100644 index 0000000..d339b49 --- /dev/null +++ b/src/Discovery.mli @@ -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 diff --git a/src/DisjCngClos.ml b/src/DisjCngClos.ml new file mode 100644 index 0000000..041585a --- /dev/null +++ b/src/DisjCngClos.ml @@ -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 diff --git a/src/DisjTransClos.ml b/src/DisjTransClos.ml new file mode 100644 index 0000000..a068feb --- /dev/null +++ b/src/DisjTransClos.ml @@ -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 diff --git a/src/Expression.ml b/src/Expression.ml new file mode 100644 index 0000000..5dcd962 --- /dev/null +++ b/src/Expression.ml @@ -0,0 +1,1096 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Expressions *) + +open Library + +open Type +open Variable +module HC = HashCons + +module L = (val Log.std Config.vExp : Log.LOG) +module LCng = (val Log.std Config.vCng : Log.LOG) + + +(*============================================================================ + Exp0 + ============================================================================*) + +(** The [Exp0] module encapsulates construction of expression descriptors. In + particular, ensuring that any simplification performed by the constructors + is applied by the expression manipulation operations in [Exp]. *) +module Exp0 : 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 HC.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 + val name : t_desc -> t + + val sort_of : t -> Var.sort + val sort_of_desc : t_desc -> Var.sort + + 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 + + exception IllSorted of t_desc + + val mkVar_ : Var.t -> t_desc + val mkApp_ : t -> t -> t_desc + val mkNil_ : t_desc + val mkAdd : t -> Fld.t -> t + val mkSub : t -> Fld.t -> t + val invert : t -> t option + val mkIdx : t -> t -> t + val mkBas_ : Typ.t -> t_desc + val mkEq_ : t -> t -> t_desc + val mkNum_ : int64 -> t_desc + val mkStr_ : string -> t_desc + val mkOp1_ : op1 -> t_desc -> t_desc + val mkOp2_ : op2 -> t_desc -> t_desc -> t_desc + val mkOp3_ : op3 -> t_desc -> t_desc -> t_desc -> t_desc + val mkOpN_ : opN -> t_desc array -> t_desc + + module Desc : HashedType with type t = t_desc + + val report_ill_sorted : t_desc -> bool + val stats : unit -> int * int * int * int * int * int + +end = struct + +(* Representation Types ===================================================== *) + +(* Expressions, [t], are hash-consed expression descriptors, [t_desc]. That + is, expression [e: t] is the unique name of descriptor [desc e]. There are + three sorts of expressions: pointer, integer, and boolean. Pointer + expressions are curried (all pointer expressions except function + application are constants) and flattened (all subexpressions are + hash-consed, and thereby uniquely named) and so subexpressions of pointer + expressions are of type [t]. Other sorts of expression are not curried or + flattened, and so their subexpressions are of type [t_desc]. *) + +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 HC.hc + +and t_desc = + | 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 + + +let desc e = e.HC.desc + + +(* Sort operations ========================================================== *) + +let rec sort_of_desc e = + match e with + | Add(_) | Sub(_) | Idx | App({HC.desc= Idx},_) -> + Var.OffsetSort + | Var(x) -> + Var.sort x + | Nil -> + Var.PointerSort + | Bas(_) -> + Var.OffsetSort + | App(f,a) -> + assert( + match desc f with + | Add _ | Sub _ -> true + | App({HC.desc= Idx}, i) -> sort_of_desc (desc i) = Var.IntegerSort + | _ -> false + ); + assert( + match desc a with + | Var(v) -> Var.sort v = Var.PointerSort + || L.warnf "sort_of_desc expected pointer: %a" Var.fmt v + | _ -> true + ); + (fun s -> assert( + s = Var.PointerSort || s = Var.OffsetSort + || L.warnf "sort_of_desc expected pointer or offset" + )) <& + sort_of_desc (desc a) + | Str(_) -> + Var.PointerSort + | Num(_) + | Op1(ZMin,_) + | Op2((ZDiv | ZRem | ZMod),_,_) + | OpN((ZAdd | ZMul | UFun(_)),_) -> + Var.IntegerSort + | Op1((Allocd | Not),_) + | Eq(_,_) + | Op2((ZLt | ZLe | ZGt | ZGe),_,_) + | OpN((Distinct | And | Or),_) -> + Var.BooleanSort + | Op3(Ite,_,e,_) -> + (fun s -> assert( s <> Var.OffsetSort )) <& + sort_of_desc e + +let sort_of e = sort_of_desc (desc e) + +let is_pointer e = sort_of_desc e = Var.PointerSort +let is_integer e = sort_of_desc e = Var.IntegerSort +let is_boolean e = sort_of_desc e = Var.BooleanSort +let is_offset e = sort_of_desc e = Var.OffsetSort + + +(* Formatting =============================================================== *) + +let rec fmtp_desc fxt ff e = + let fmtp ff e = fmtp fxt ff e in + let fmtp_desc ff e = fmtp_desc fxt ff e in + try + match e with + | Var(v) -> + Var.fmtp fxt ff v + | Bas(t) -> + Format.fprintf ff "@[%a@@@]" Typ.fmt (Typ.mkPointer t) + | App({HC.desc= Add(f)},{HC.desc= Bas(_)}) -> + Format.fprintf ff "@[%a@]" Fld.fmt f + | App({HC.desc= Add(f)},a) when is_offset e -> + Format.fprintf ff "@[%a.%a@]" fmtp a Fld.fmt f + | Nil -> + Format.fprintf ff "@[NULL@]" + | App({HC.desc= Add(f)}, a) when !Config.c_syntax -> + Format.fprintf ff "@[&(%a->%a)@]" fmtp a Fld.fmt f + | App({HC.desc= Add(f)}, a) -> + Format.fprintf ff "@[%a+%a@]" fmtp a Fld.fmt f + | App({HC.desc= Sub(f)}, a) when !Config.c_syntax -> + Format.fprintf ff "@[CONTAINING_RECORD(%a,@ %a,@ %a)@]" fmtp a Typ.fmt (Fld.typ f) Fld.fmt f + | App({HC.desc= Sub(f)}, a) -> + Format.fprintf ff "@[%a-%a@]" fmtp a Fld.fmt f + | App({HC.desc= App({HC.desc=Idx},i)}, a) -> + Format.fprintf ff "@[%a[%a]@]" fmtp a fmtp i + | App(f,a) -> + Format.fprintf ff "@[%a(%a)@]" fmtp f fmtp a + | Add(f) -> + Format.fprintf ff "@[+%a@]" Fld.fmt f + | Sub(f) -> + Format.fprintf ff "@[-%a@]" Fld.fmt f + | Idx -> + Format.fprintf ff "@[Idx@]" + | Str(s) -> + Format.fprintf ff "@[\"%s\"@]" s + | Num(n) -> + Format.fprintf ff "%Li" n + | Op1(Allocd,e) -> + Format.fprintf ff "@[allocd(%a)@]" fmtp_desc e + | Op1(Not,Eq(e,f)) -> + Format.fprintf ff "@[(%a !=@ %a)@]" fmtp e fmtp f + | Op1(Not,a) -> + Format.fprintf ff "@[!%a@]" fmtp_desc a + | Op1(ZMin,e) -> + Format.fprintf ff "@[-%a@]" fmtp_desc e + | Eq(e,f) -> + Format.fprintf ff "@[(%a ==@ %a)@]" fmtp e fmtp f + | Op2(ZLt,e,f) -> + Format.fprintf ff "@[(%a <@ %a)@]" fmtp_desc e fmtp_desc f + | Op2(ZLe,e,f) -> + Format.fprintf ff "@[(%a <=@ %a)@]" fmtp_desc e fmtp_desc f + | Op2(ZGt,e,f) -> + Format.fprintf ff "@[(%a >@ %a)@]" fmtp_desc e fmtp_desc f + | Op2(ZGe,e,f) -> + Format.fprintf ff "@[(%a >=@ %a)@]" fmtp_desc e fmtp_desc f + | Op2(ZDiv,e,f) -> + Format.fprintf ff "@[(%a /@ %a)@]" fmtp_desc e fmtp_desc f + | Op2(ZRem,e,f) -> + Format.fprintf ff "@[(%a %%@ %a)@]" fmtp_desc e fmtp_desc f + | Op2(ZMod,e,f) -> + Format.fprintf ff "@[(%a mod@ %a)@]" fmtp_desc e fmtp_desc f + | Op3(Ite,g,t,e) -> + Format.fprintf ff "@[(%a ? %a : %a)@]" fmtp_desc g fmtp_desc t fmtp_desc e + | OpN(Distinct,es) -> + Format.fprintf ff "@[<%a>@]" (Array.fmt " !=@ " fmtp_desc) es + | OpN(And,[||]) -> + Format.fprintf ff "tt" + | OpN(And,[|OpN(Or,[||])|]) -> + Format.fprintf ff "ff" + | OpN(And,cn) -> + Format.fprintf ff "@[[@[%a@]]@]" (Array.fmt " ^@ " fmtp_desc) cn + | OpN(Or,[||]) -> + Format.fprintf ff "ff" + | OpN(Or,dn) -> + Format.fprintf ff "@[{@[%a@]}@]" (Array.fmt " v@ " fmtp_desc) dn + | OpN(ZAdd,es) -> + Format.fprintf ff "@[(%a)@]" (Array.fmt " +@ " fmtp_desc) es + | OpN(ZMul,es) -> + Format.fprintf ff "@[(%a)@]" (Array.fmt " *@ " fmtp_desc) es + | OpN(UFun(s),es) -> + Format.fprintf ff "@[\"%s\"(%a)@]" s (Array.fmt ",@ " fmtp_desc) es + with Nothing_to_fmt -> () + +and fmtp fxt ff e = + if !Config.vExp > 0 + then Format.fprintf ff "@[(%a)@@%i@]" (fmtp_desc fxt) (desc e) e.HC.id + else fmtp_desc fxt ff (desc e) + +let fmt_desc ff e = fmtp_desc (Vars.empty,Vars.empty) ff e + +let fmt ff e = fmtp (Vars.empty,Vars.empty) ff e + + +let fmt_caml_op1 = function + | Allocd -> "E.Allocd" | Not -> "E.Not" | ZMin -> "E.ZMin" + +let fmt_caml_op2 = function + | ZLt -> "E.ZLt" | ZLe -> "E.ZLe" | ZGt -> "E.ZGt" | ZGe -> "E.ZGe" + | ZDiv -> "E.ZDiv" | ZRem -> "E.ZRem" | ZMod -> "E.ZMod" + +let fmt_caml_op3 = function + | Ite -> "E.Ite" + +let fmt_caml_opN = function + | Distinct -> "E.Distinct" | And -> "E.And" | Or -> "E.Or" + | ZAdd -> "E.ZAdd" | ZMul -> "E.ZMul" | UFun(s) -> "(E.UFun \""^s^"\")" + +let fmt_caml ff e = + let rec fmt_caml_ ff = function + | Var(v) -> + Format.fprintf ff "@[(E.mkVar@ %a)@]" Var.fmt_caml v + | App(f,a) -> + (match desc f with + | Add(f) -> + Format.fprintf ff "@[(E.mkAdd@ %a@ %a)@]" fmt_caml_ (desc a) Fld.fmt_caml f + | Sub(f) -> + Format.fprintf ff "@[(E.mkSub@ %a@ %a)@]" fmt_caml_ (desc a) Fld.fmt_caml f + | App({HC.desc=Idx},i) -> + Format.fprintf ff "@[(E.mkIdx@ %a@ %a)@]" fmt_caml_ (desc a) fmt_caml_ (desc i) + | f -> + Format.fprintf ff "@[(E.mkApp@ %a@ %a)@]" fmt_caml_ f fmt_caml_ (desc a) + ) + | Nil -> + Format.fprintf ff "@[E.mkNil@]" + | Bas(t) -> + Format.fprintf ff "@[(E.mkBas(%a))@]" Typ.fmt_caml t + | Eq(x,y) -> + Format.fprintf ff "@[(E.mkEq@ %a@ %a)@]" fmt_caml_ (desc x) fmt_caml_ (desc y) + | Num(n) -> + Format.fprintf ff "@[(E.mkNum(%Li))@]" n + | Str(s) -> + Format.fprintf ff "@[(E.mkStr(\"%s\"))@]" s + | Op1(o,x) -> + Format.fprintf ff "@[(E.mkOp1@ %s@ %a)@]" (fmt_caml_op1 o) fmt_caml_ x + | Op2(o,x,y) -> + Format.fprintf ff "@[(E.mkOp2@ %s@ %a@ %a)@]" (fmt_caml_op2 o) fmt_caml_ x fmt_caml_ y + | Op3(o,g,t,e) -> + Format.fprintf ff "@[(E.mkOp3@ %s@ %a@ %a@ %a)@]" (fmt_caml_op3 o) fmt_caml_ g fmt_caml_ t fmt_caml_ e + | OpN(f,xs) -> + Format.fprintf ff "@[(E.mkOpN@ %s@ [|@[%a@]|])@]" (fmt_caml_opN f) (Array.fmt ";@ " fmt_caml_) xs + | Add _ | Sub _ | Idx -> + assert false (* malformed *) + in + fmt_caml_ ff (desc e) + + +(* Comparison =============================================================== *) + +let rec hash_desc x = + match x with + | Var(v) -> Var.hash v + | App(f,a) -> Hashtbl.hash (hash f, hash a) + | Add(f) -> Hashtbl.hash (Fld.id f) + | Sub(f) -> Hashtbl.hash (- (Fld.id f)) + | Bas(t) -> Typ.hash t + | Eq(a,b) -> Hashtbl.hash (hash a, hash b) + | Nil | Idx | Num _ | Str _ | Op1 _ | Op2 _ | Op3 _ | OpN _ -> Hashtbl.hash x + +and hash x = x.HC.hash + &> (fun n -> assert( n = hash_desc x.HC.desc || failwithf "mis-hashed: %a" fmt x )) + +let compare_sort x y = + let open Var in + if x == y then 0 else + match x, y with + | (PointerSort | IntegerSort | BooleanSort), OffsetSort -> -1 + | OffsetSort, (PointerSort | IntegerSort | BooleanSort) -> 1 + | _ -> Pervasives.compare x y + +(* Note that this order is used in the selection of equivalence class representatives, and there is an + implicit dependency that Var's compare greater than other offset expressions. Otherwise, normalizing + offset expressions wrt a congruence relation may not preserve well-formedness of offsets. *) +let rec compare_desc x y = + if x == y then 0 else + match x, y with + | Var(v), Var(w) -> let z = compare_sort (Var.sort v) (Var.sort w) in if z<>0 then z else Var.compare v w + | App(f,a), App(g,d) -> let z = compare a d in if z<>0 then z else compare f g + | Nil, Nil -> 0 + | Add(f), Add(g) -> Fld.compare f g + | Sub(f), Sub(g) -> Fld.compare f g + | Idx, Idx -> 0 + | Bas(s), Bas(t) -> Typ.compare s t + | Eq(a,b), Eq(d,e) -> let z = compare a d in if z<>0 then z else compare b e + | Num(m), Num(n) -> Int64.compare m n + | Str(x), Str(y) -> String.compare x y + | Op1(o,a), Op1(p,d) -> + let z = Pervasives.compare o p in if z<>0 then z else compare_desc a d + | Op2(o,a,b), Op2(p,d,e) -> + let z = Pervasives.compare o p in if z<>0 then z else + let z = compare_desc a d in if z<>0 then z else + compare_desc b e + | Op3(o,a,b,c), Op3(p,d,e,f) -> + let z = Pervasives.compare o p in if z<>0 then z else + let z = compare_desc a d in if z<>0 then z else + let z = compare_desc b e in if z<>0 then z else + compare_desc c f + | OpN(o,a), OpN(p,d) -> + let z = Pervasives.compare o p in if z<>0 then z else + Array.compare compare_desc a d + | Nil , _ -> -1 | _, Nil -> 1 + | Bas _, _ -> -1 | _, Bas _ -> 1 + | Num _, _ -> -1 | _, Num _ -> 1 + | Str _, _ -> -1 | _, Str _ -> 1 + | Add _, _ -> -1 | _, Add _ -> 1 + | Sub _, _ -> -1 | _, Sub _ -> 1 + | Idx , _ -> -1 | _, Idx -> 1 + | _, Var(v) when Var.sort v = Var.OffsetSort -> -1 + | Var(v), _ when Var.sort v = Var.OffsetSort -> 1 + | Var _, _ -> -1 | _, Var _ -> 1 + | App _, _ -> -1 | _, App _ -> 1 + | Eq _, _ -> -1 | _, Eq _ -> 1 + | Op1 _, _ -> -1 | _, Op1 _ -> 1 + | Op2 _, _ -> -1 | _, Op2 _ -> 1 + | Op3 _, _ -> -1 | _, Op3 _ -> 1 + +and compare x y = + if x == y then 0 else + compare_desc x.HC.desc y.HC.desc + +(* let compare x y = Pervasives.compare x.HC.id y.HC.id *) + +(* The equality relation passed to HashCons.Make is used on shallow copies of possibly-dead values, so + physical disequality and disequality of ids cannot be relied upon. *) +let rec equal_desc x y = + (fun eq -> assert( + (not eq || hash_desc x = hash_desc y + || failwithf "@[hash %a = %i <> %i = hash %a@]" fmt_desc x (hash_desc x) (hash_desc y) fmt_desc y) )) + <& + let equal x y = + (x == y) || (x.HC.id = y.HC.id) || (equal_desc x.HC.desc y.HC.desc) + in + (x == y) || + match x, y with + | Var(v), Var(w) -> Var.equal v w + | App(f,a), App(g,d) -> equal f g && equal a d + | Nil, Nil -> true + | Add(f), Add(g) -> Fld.equal f g + | Sub(f), Sub(g) -> Fld.equal f g + | Idx, Idx -> true + | Bas(s), Bas(t) -> Typ.equal s t + | Eq(a,b), Eq(d,e) -> equal a d && equal b e + | Num(m), Num(n) -> m = n + | Str(x), Str(y) -> x = y + | Op1(o,a), Op1(p,d) -> o = p && equal_desc a d + | Op2(o,a,b), Op2(p,d,e) -> o = p && equal_desc a d && equal_desc b e + | Op3(o,a,b,c), Op3(p,d,e,f) -> o = p && equal_desc a d && equal_desc b e && equal_desc c f + | OpN(o,a), OpN(p,d) -> o = p && Array.equal equal_desc a d + | ( Var _ | App _ | Nil | Add _ | Sub _ | Idx | Bas _ | + Eq _ | Num _ | Str _ | Op1 _ | Op2 _ | Op3 _ | OpN _ ), _ -> false + + +(* Hash-Consing ============================================================= *) + +module Desc = struct + type t = t_desc + let equal x y = equal_desc x y + let hash x = hash_desc x + let fmt = fmt_desc +end + +module HCTbl = HC.Make(Desc) + +let tbl = HCTbl.create Config.exp_hc_initial_size + +let stats () = HCTbl.stats tbl + +let name d = HCTbl.intern tbl d + +let equal x y = (x == y) + &> (fun ptr_eq -> assert( + let id_eq = (x.HC.id = y.HC.id) in + let desc_eq = equal_desc x.HC.desc y.HC.desc in + let hash_eq = (hash x = hash y) in + (not desc_eq || hash_eq + || failwithf "@[hash %a = %i != %i = hash %a@]" fmt x (hash x) (hash y) fmt y) && + (match HCTbl.find_all tbl x with + | [] -> L.warnf "@[not in tbl: %a@]" fmt x + | [x'] -> (x' == x) || L.warnf "@[!= in tbl: %a != %a@]" fmt x fmt x' + | _ -> L.warnf "@[multiply in tbl: %a@]" fmt x) && + (match HCTbl.find_all tbl y with + | [] -> L.warnf "@[not in tbl: %a@]" fmt y + | [y'] -> (y' == y) || L.warnf "@[!= in tbl: %a != %a@]" fmt y fmt y' + | _ -> L.warnf "@[multiply in tbl: %a@]" fmt y) && + (ptr_eq = id_eq + || L.warnf "@[%a %s %a@]" fmt x (if ptr_eq then "== but id <>" else "!= but id =") fmt y) && + (id_eq = desc_eq + || L.warnf "@[%a %s %a@]" fmt x (if id_eq then "id = but desc <>" else "id <> but desc =") fmt y) && + (desc_eq = ptr_eq + || L.warnf "@[%a %s %a@]" fmt x (if ptr_eq then "== but desc <>" else "!= but desc =") fmt y) )) + + +(* Desc Constructors ======================================================== *) + +exception IllSorted of t_desc + +let _ = + Printexc.register_printer (function + | IllSorted(e) -> Config.vVar := 5 ; Some(Format.asprintf "ill-sorted: %a" fmt_desc e) + | _ -> None + ) + +let report_ill_sorted e = + if Config.check_sorts + then raise (IllSorted(e)) + else L.warnf "ill-sorted: %a" fmt_desc e + + +let mkVar_ v = Var(v) + +let mkApp_ f a = + match desc f, desc a with + (* d+g ==> d when g is the first field of its type *) + | Add g, d when Fld.is_first g -> + d + (* d-g ==> d when g is the first field of its type *) + | Sub g, d when Fld.is_first g -> + d + (* d-g+g ==> d *) + | Add g, App({HC.desc= Sub h}, {HC.desc= d}) when Fld.equal g h -> + d + (* d+g-g ==> d *) + | Sub g, App({HC.desc= Add h}, {HC.desc= d}) when Fld.equal g h -> + d + | _ -> + App(f, a) + +let mkNil_ = Nil + +let mkAdd e f = name (mkApp_ (name (Add(f))) e) +let mkSub e f = name (mkApp_ (name (Sub(f))) e) +let mkIdx_ = name Idx +let mkIdx a i = name (mkApp_ (name (mkApp_ mkIdx_ i)) a) + +let mkBas_ t = Bas(t) + +let invert e = + match desc e with + | Add(o) -> Some(name(Sub(o))) + | Sub(o) -> Some(name(Add(o))) + | _ -> None + +let mkNum_ n = Num(n) + +let mkStr_ s = Str(s) + +let tt = OpN(And,[||]) +let ff = OpN(Or,[||]) + + +let mkEq__ i j = + match compare i j with + | 0 -> tt + | o when o > 0 -> Eq(j,i) + | _ -> Eq(i,j) + + +let rec expandIte g t e exp = + if not Config.exp_expand_ite then exp else + mkOpN_ Or [|mkOpN_ And [|g; t|]; mkOpN_ And [|mkOp1_ Not g; e|]|] + +and mkEqIte e gtf g t f = + match g with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> mkEq_ e (name t) + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkEq_ e (name f) + | _ -> + match mkEq_ e (name t) with + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOpN_ And [|mkOp1_ Not g; mkEq_ e (name f)|] + | e_t -> + match mkEq_ e (name f) with + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOpN_ And [|g; mkEq_ e (name t)|] + | e_f -> + expandIte g e_t e_f (mkEq__ e gtf) + +and mkEq_ i j = + assert( sort_of i = sort_of j + || report_ill_sorted (Eq(i,j)) + ); + if not Config.exp_simplify then Eq(i,j) else + match desc i, desc j with + | Num(m), Num(n) -> if m = n then tt else ff + | _, Op3(Ite,g,t,f) -> mkEqIte i j g t f + | Op3(Ite,g,t,f), _ -> mkEqIte j i g t f + | _ -> mkEq__ i j + +(* Converts to negation-normal form. This is not conditional on simplify + since other operations (e.g. remove) do not track polarity. *) +and mkOp1_ o i = + assert( + (match o with + | Allocd -> is_pointer i + | Not -> is_boolean i + | ZMin -> is_integer i + ) || report_ill_sorted (Op1(o, i)) + ); + match o with + | Not -> + (match i with + | Op1(Not,j) -> j + | Op2(ZLt,j,k) -> mkOp2_ ZGe j k + | Op2(ZLe,j,k) -> mkOp2_ ZGt j k + | Op2(ZGt,j,k) -> mkOp2_ ZLe j k + | Op2(ZGe,j,k) -> mkOp2_ ZLt j k + | Op3(Ite,g,t,f) -> mkOp3_ Ite g (mkOp1_ Not t) (mkOp1_ Not f) + | OpN(And,is) -> mkOpN_ Or (Array.map (fun i -> mkOp1_ Not i) is) + | OpN(Or,is) -> mkOpN_ And (Array.map (fun i -> mkOp1_ Not i) is) + | _ -> Op1(Not, i) + ) + | _ -> + Op1(o, i) + +and mkOp2_ o i j = + assert( is_integer i && is_integer j + || report_ill_sorted (Op2(o, i, j)) + ); + if not Config.exp_simplify then Op2(o, i, j) else + match o, i, j with + | ZLt, Num(m), Num(n) -> if m < n then tt else ff + | ZLe, Num(m), Num(n) -> if m <= n then tt else ff + | ZGt, Num(m), Num(n) -> if m > n then tt else ff + | ZGe, Num(m), Num(n) -> if m >= n then tt else ff + | _, e, Op3(Ite,g,t,f) -> + (match g with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> mkOp2_ o e t + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOp2_ o e f + | _ -> + match mkOp2_ o e t with + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOp2_ o e f + | e_t -> + match mkOp2_ o e f with + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOp2_ o e t + | e_f -> + expandIte g e_t e_f (Op2(o, e, j)) + ) + | _, Op3(Ite,g,t,f), e -> + (match g with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> mkOp2_ o t e + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOp2_ o f e + | _ -> + match mkOp2_ o t e with + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOp2_ o f e + | e_t -> + match mkOp2_ o f e with + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOp2_ o t e + | e_f -> + expandIte g e_t e_f (Op2(o, i, e)) + ) + | _ -> Op2(o, i, j) + +and mkOp3_ o g t f = + assert( is_boolean g && sort_of_desc t = sort_of_desc f + (* Warning: SH.pure_consequences constructs ill-sorted exps of the following form: *) + || (sort_of_desc t = Var.PointerSort && match f with Num(n) when n < 0L -> true | _ -> false) + || report_ill_sorted (Op3(o, g, t, f)) + ); + if not Config.exp_simplify then Op3(o, g, t, f) else + match o with + | Ite -> + match g with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> t + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> f + | _ -> + match t with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> mkOpN_ Or [|g; f|] + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOpN_ And [|mkOp1_ Not g; f|] + | _ -> + match f with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> mkOpN_ Or [|g; t|] + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> mkOpN_ And [|g; t|] + | _ -> + expandIte g t f (Op3(Ite, g, t, f)) + +and mkOpN_ o es = + assert( + (match o with + | Distinct -> Array.for_all (fun j -> sort_of_desc es.(0) = sort_of_desc j) es + | And | Or -> Array.for_all is_boolean es + | ZAdd | ZMul | UFun _ -> Array.for_all is_integer es + ) || report_ill_sorted (OpN(o, es)) + ); + if not Config.exp_simplify then OpN(o, es) else + match o with + | And -> + let rec filter e es = + match es with + | [f] when f == ff -> es + | _ -> + match e with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> es + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> [ff] + | Op3(Ite,g,t,f) -> + let ite = expandIte g t f e in + if ite == e then + e :: es + else + List.fold filter [ite] es + | _ -> e :: es + in + (match Array.fold_right filter es [] with + | [e] -> e + | es -> OpN(And, Array.of_list es) + ) + | Or -> + let rec filter e es = + match es with + | [t] when t == tt -> es + | _ -> + match e with + | (* tt *) OpN(And,[||]) | OpN(Or,[|OpN(And,[||])|]) -> [tt] + | (* ff *) OpN(Or,[||]) | OpN(And,[|OpN(Or,[||])|]) -> es + | Op3(Ite,g,t,f) -> + let ite = expandIte g t f e in + if ite == e then + e :: es + else + List.fold filter [ite] es + | _ -> e :: es + in + (match Array.fold_right filter es [] with + | [e] -> e + | es -> OpN(Or, Array.of_list es) + ) + | Distinct -> + (match es with + | [||] | [|_|] -> tt + | _ -> OpN(o, es) + ) + | _ -> + OpN(o, es) + +end + + +(*============================================================================ + Exp + ============================================================================*) + +module Exp = struct + +include Exp0 + +(* Sort operations ========================================================== *) + +let is_pointer e = sort_of e = Var.PointerSort +let is_integer e = sort_of e = Var.IntegerSort +let is_boolean e = sort_of e = Var.BooleanSort +let is_offset e = sort_of e = Var.OffsetSort + + +(* Constructors ============================================================= *) + +let mkVar v = name (mkVar_ v) + +(* Pointer expressions *) + +let mkApp e f = name (mkApp_ e f) +let getApp e = match desc e with App(f,a) -> Some(f,a) | _ -> None + +let nil = name mkNil_ + +let mkAdds e fN_f1 = List.fold_right (fun fI e_f1_fI1 -> mkAdd e_f1_fI1 fI) fN_f1 e +let mkSubs e fN_f1 = List.fold_left (fun e_fN_fI1 fI -> mkSub e_fN_fI1 fI) e fN_f1 + +(* Offset expressions *) + +let mkBas t = name (mkBas_ t) + +(* Integer expressions *) + +let mkNum n = name (mkNum_ n) +let zero = mkNum 0L +let one = mkNum 1L + +let mkStr n = name (mkStr_ n) + +let mkOp1 o i = name (mkOp1_ o i) +let mkOp2 o i j = name (mkOp2_ o i j) +let mkOp3 o i j k = name (mkOp3_ o i j k) +let mkOpN o is = name (mkOpN_ o is) + +let mkZMin i = mkOp1 ZMin (desc i) +let mkZAdd is = mkOpN ZAdd (Array.map desc is) +let mkZSub is = mkOpN ZAdd (Array.mapi (fun n i -> if n = 0 then desc i else mkOp1_ ZMin (desc i)) is) +let mkZMul is = mkOpN ZMul (Array.map desc is) +let mkZDiv i j = mkOp2 ZDiv (desc i) (desc j) +let mkZRem i j = mkOp2 ZRem (desc i) (desc j) +let mkZMod i j = mkOp2 ZMod (desc i) (desc j) + +let mkUFun s es = mkOpN (UFun(s)) (Array.map desc es) + +(* Boolean expressions *) + +let mkAllocd e = mkOp1 Allocd (desc e) +let mkEq e f = name (mkEq_ e f) +let mkDq e f = mkOp1 Not (mkEq_ e f) +let mkDistinct es = mkOpN Distinct (Array.map desc es) + +let mkZLt i j = mkOp2 ZLt (desc i) (desc j) +let mkZLe i j = mkOp2 ZLe (desc i) (desc j) +let mkZGt i j = mkOp2 ZGt (desc i) (desc j) +let mkZGe i j = mkOp2 ZGe (desc i) (desc j) + +let mkNot b = mkOp1 Not (desc b) +let mkAnd bs = mkOpN And (Array.map desc bs) +let mkOr bs = mkOpN Or (Array.map desc bs) + +let mkImp b c = mkOpN Or [|mkOp1_ Not (desc b); desc c|] +let mkIff b c = mkOpN And [|mkOpN_ Or [|mkOp1_ Not (desc b); desc c|]; + mkOpN_ Or [|mkOp1_ Not (desc c); desc b|]|] +let mkXor b c = mkOpN Or [|mkOpN_ And [|mkOp1_ Not (desc b); desc c|]; + mkOpN_ And [|mkOp1_ Not (desc c); desc b|]|] + +let tt = mkAnd [||] +let ff = mkOr [||] + +(* Generic expressions *) + +let mkIte b e f = mkOp3 Ite (desc b) (desc e) (desc f) + + +(* Conversions ============================================================== *) + +let convert s e = + (fun eo -> assert( match eo with Some(e') -> sort_of e' = s || report_ill_sorted (desc e') | None -> true )) + <& + match s, desc e with + | Var.IntegerSort, Nil -> Some(zero) + | Var.BooleanSort, Nil -> Some(ff) + | Var.PointerSort, Num(0L) -> Some(nil) + | Var.BooleanSort, Num(0L) -> Some(ff) + | Var.BooleanSort, Num _ -> Some(tt) + | _ -> + match s, sort_of e with + | Var.PointerSort, Var.PointerSort + | Var.IntegerSort, Var.IntegerSort + | Var.BooleanSort, Var.BooleanSort + | Var.OffsetSort , Var.OffsetSort -> Some(e) + | Var.BooleanSort, Var.PointerSort -> Some(mkDq nil e) + | Var.BooleanSort, Var.IntegerSort -> Some(mkDq zero e) + | Var.IntegerSort, Var.BooleanSort -> Some(mkIte e one zero) + | Var.BooleanSort, Var.OffsetSort + | Var.IntegerSort, (Var.PointerSort | Var.OffsetSort) + | Var.PointerSort, (Var.IntegerSort | Var.BooleanSort | Var.OffsetSort) + | Var.OffsetSort , (Var.PointerSort | Var.IntegerSort | Var.BooleanSort) -> None + + +(* Traversals =============================================================== *) + +let fold_sp dn up e sa pa = + let rec fsp e sa pa = + let sa = dn e sa in + let pa = + match desc e with + | App(f,a) -> fsp f sa (fsp a sa pa) + | Op1(_,a) -> fsp (name a) sa pa + | Eq(a,b) -> fsp a sa (fsp b sa pa) + | Op2(_,a,b) -> fsp (name a) sa (fsp (name b) sa pa) + | Op3(_,a,b,c) -> fsp (name a) sa (fsp (name b) sa (fsp (name c) sa pa)) + | OpN(_,a) -> Array.fold_right (fun a pa -> fsp (name a) sa pa) a pa + | _ -> pa + in up e sa pa + in fsp e sa pa + + +let rec fold fn e z = + let z = + match desc e with + | App(f,a) -> fold fn f (fold fn a z) + | Op1(_,a) -> fold fn (name a) z + | Eq(a,b) -> fold fn a (fold fn b z) + | Op2(_,a,b) -> fold fn (name a) (fold fn (name b) z) + | Op3(_,a,b,c) -> fold fn (name a) (fold fn (name b) (fold fn (name c) z)) + | OpN(_,a) -> Array.fold_right (fun a z -> fold fn (name a) z) a z + | _ -> z + in fn e z + + +let map fn e = +(* L.incf 0 "( Exp.map: %a" fmt e ; L.decf 0 ") Exp.map: %a" fmt <& *) + let rec map_desc_ e = desc (map_ (name e)) + and map_ e = + let e' = + match desc e with + | App(f,a) -> mkApp (map_ f) (map_ a) + | Op1(o,a) -> mkOp1 o (map_desc_ a) + | Eq(a,b) -> mkEq (map_ a) (map_ b) + | Op2(o,a,b) -> mkOp2 o (map_desc_ a) (map_desc_ b) + | Op3(o,a,b,c) -> mkOp3 o (map_desc_ a) (map_desc_ b) (map_desc_ c) + | OpN(o,a) -> mkOpN o (Array.map map_desc_ a) + | _ -> e + in fn e' + in map_ e + + +let pmap fn e = +(* L.incf 0 "( Exp.pmap: %a" fmt e ; L.decf 0 ") Exp.pmap: %a" fmt <& *) + let rec pmap_desc_ e = desc (pmap_ (name e)) + and pmap_ e = +(* L.incf 0 "( Exp.pmap_: %a" fmt e ; L.decf 0 ") Exp.pmap_: %a" fmt <& *) + match fn e with + | Some(e') -> e' + | None -> + match desc e with + | App(f,a) -> mkApp (pmap_ f) (pmap_ a) + | Op1(o,a) -> mkOp1 o (pmap_desc_ a) + | Eq(a,b) -> mkEq (pmap_ a) (pmap_ b) + | Op2(o,a,b) -> mkOp2 o (pmap_desc_ a) (pmap_desc_ b) + | Op3(o,a,b,c) -> mkOp3 o (pmap_desc_ a) (pmap_desc_ b) (pmap_desc_ c) + | OpN(o,a) -> mkOpN o (Array.map pmap_desc_ a) + | (Var _ | Nil | Bas _ | Add _ | Sub _ | Idx | Num _ | Str _) -> e + in pmap_ e + + +let remove pred e = + (fun e' -> assert( + e == e' || not (equal e e') + || failwithf "Exp.remove broke ==: %a %a" fmt e fmt e')) + <& + let rec remove_ e = + (* [mul* mk] transforms constructors that treat [tt] as a zero *) + let mul1 mk x = + Option.map (fun x' -> + if Desc.equal x x' then e else mk x' + ) (remove_ x) + in + let mul2 mk x y = + Option.map2 (fun x' y' -> + if Desc.equal x x' && Desc.equal y y' then e else mk x' y' + ) (remove_ x) (remove_ y) + in + let mul2t mk x y = + mul2 (fun x y -> mk (name x) (name y)) (desc x) (desc y) + in + let mul3 mk x y z = + Option.map3 (fun x' y' z' -> + if Desc.equal x x' && Desc.equal y y' && Desc.equal z z' then e + else mk x' y' z' + ) (remove_ x) (remove_ y) (remove_ z) + in + let mulN mk xs = + Option.mapN (fun xs' -> + if Array.equal Desc.equal xs xs' then e else mk xs' + ) (Array.map remove_ xs) + in + (* [add* mk] transforms constructors that treat [tt] as a unit *) + let addN mk xs = + let xs' = + Array.of_list (Array.fold_right (fun x xs' -> + match remove_ x with + | None -> xs' + | Some(x') -> x' :: xs' + ) xs []) in + Some(if Array.equal Desc.equal xs xs' then e else mk xs') + in + match e with + (* compound boolean expressions: descend *) + | OpN(And,cn) -> addN (mkOpN_ And) cn + | OpN(Or,dn) -> mulN (mkOpN_ Or) dn + | Op1(Not,x) -> mul1 (mkOp1_ Not) x + | Op3(Ite,g,t,e) when sort_of_desc t = Var.BooleanSort + -> mul3 (mkOp3_ Ite) g t e + + (* non-boolean and atomic boolean expressions: remove if pred fails *) + | _ when pred e -> None + + (* non-boolean and atomic boolean expressions where pred holds: descend *) + | Var _ | Nil | Bas _ | Add _ | Sub _ | Idx | Num _ | Str _ + -> Some(e) + | App(x,y) -> mul2t mkApp_ x y + | Op1(o,x) -> mul1 (mkOp1_ o) x + | Eq(x,y) -> mul2t mkEq_ x y + | Op2(o,x,y) -> mul2 (mkOp2_ o) x y + | Op3(Ite,g,t,e) -> mul3 (mkOp3_ Ite) g t e + | OpN(Distinct,x) -> addN (mkOpN_ Distinct) x + | OpN(o,x) -> mulN (mkOpN_ o) x + in + match remove_ (desc e) with + | None -> tt + | Some(e') -> name e' + + +(* Queries ================================================================== *) + +let fv x = + fold (fun e vs -> + match desc e with + | Var(v) -> Vars.add v vs + | _ -> vs + ) x Vars.empty + + +end + + + +(*============================================================================ + Off + ============================================================================*) + +module Off = struct + + type t = Exp.t + (* Offsets are expressions of the form accepted by [Exp.is_offset]. *) + + type desc = Var of Var.t | Path of Typ.t * Fld.t list + + + let mk e = assert( Exp.is_offset e ); e + + let mkVar v = Exp.mkVar v + + (* [mkPath ty [fN; ...; f2; f1]] is [(ty)0+f1+f2+...+fN] *) + let mkPath ty fs = Exp.mkAdds (Exp.mkBas(ty)) fs + + + let rec fold_path fn o z = + match Exp.desc o with + | Exp.Bas(ty) -> (ty, z) + | Exp.Add(fld) -> (Fld.typ fld, fn fld z) + | Exp.App(f,a) -> + (match Exp.desc f with + | Exp.Add(fld) -> + let ty, z = fold_path fn a z in + (ty, fn fld z) + | _ -> invalid_argf "malformed offset: %a" Exp.fmt f) + | _ -> invalid_argf "malformed offset: %a" Exp.fmt o + + let desc o = + match Exp.desc o with + | Exp.Var(v) -> + Var(v) + | _ -> + let ty, fs = fold_path List.cons o [] in + Path(ty, fs) + + + let fv o = + match desc o with + | Var(v) -> Vars.singleton v + | Path _ -> Vars.empty + + + let is_base o = + match Exp.desc o with + | Exp.Var _ -> + None + | _ -> + match + fold_path (fun fld is_base -> + is_base && Fld.is_first fld + ) o true + with + | typ, true -> + Some(typ) + | _ -> + None + + + let equal = Exp.equal + let compare = Exp.compare + + let fmtp fxt ff o = + match desc o with + | Var(v) -> + Var.fmtp fxt ff v + | Path(ty,fs) -> + let fmt_ty ff ty = + if !Config.vTyp > 0 + then Format.fprintf ff "(%a0)%s" Typ.fmt ty (if fs=[] then "" else ".") + and fmt_fs ff fs = + let fs = if fs <> [] then fs else match List.rev (Typ.fst_flds ty) with f :: _ -> [f] | [] -> [] in + List.fmt "." Fld.fmt ff fs + in + Format.fprintf ff "%a%a" fmt_ty ty fmt_fs (List.rev fs) + + let fmt ff = fmtp (Vars.empty,Vars.empty) ff + + let fmt_caml ff o = + match desc o with + | Var(v) -> + Format.fprintf ff "Off.mkVar %a" Var.fmt_caml v + | Path(t,p) -> + Format.fprintf ff "Off.mkPath %a [%a]" + Typ.fmt_caml t (List.fmt ";" Fld.fmt_caml) p + +end + + + +(*============================================================================ + Collections + ============================================================================*) + +module Exps = struct + include Set.Make(Exp) +(* include Set.Make(struct *) +(* include Exp *) +(* let compare x y = Pervasives.compare x.HC.id y.HC.id *) +(* end) *) + + let fv es = fold (fun e -> Vars.union (Exp.fv e)) es Vars.empty + + let fmt_sep sep ff es = List.fmt sep Exp.fmt ff (to_list es) + let fmt = fmt_sep ",@ " +end + +module Expss = Set.Make(Exps) +module ExpMap = Map.Make(Exp) +module ExpMMap = MultiMap.Make(Exp)(Exps) +module ExpHMap = HashMap.Make(Exp) + +let stats = Exp.stats diff --git a/src/Expression.mli b/src/Expression.mli new file mode 100644 index 0000000..6935060 --- /dev/null +++ b/src/Expression.mli @@ -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) diff --git a/src/FLD.ml b/src/FLD.ml new file mode 100644 index 0000000..53ea851 --- /dev/null +++ b/src/FLD.ml @@ -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 diff --git a/src/FORMULA.ml b/src/FORMULA.ml new file mode 100644 index 0000000..55bde0f --- /dev/null +++ b/src/FORMULA.ml @@ -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 diff --git a/src/Frame.ml b/src/Frame.ml new file mode 100644 index 0000000..4fce91a --- /dev/null +++ b/src/Frame.ml @@ -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) diff --git a/src/Frame.mli b/src/Frame.mli new file mode 100644 index 0000000..5719a3c --- /dev/null +++ b/src/Frame.mli @@ -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 diff --git a/src/Frontend.ml b/src/Frontend.ml new file mode 100644 index 0000000..1d888f5 --- /dev/null +++ b/src/Frontend.ml @@ -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 + ) diff --git a/src/Graph.ml b/src/Graph.ml new file mode 100644 index 0000000..ee77205 --- /dev/null +++ b/src/Graph.ml @@ -0,0 +1,1018 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Mutable edge- and vertex-labelled multi-graphs *) + +open Library + +module L = (val Log.std Config.vGraph : Log.LOG) + + +(*============================================================================ + Graph + ============================================================================*) + +include Graph_sig + + +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 + ) + = +struct + + type index = Index.t + type v_label = VertexLabel.t + type e_label = EdgeLabel.t + + module EdgeLabelSet = Set.Make(EdgeLabel) + + + module rec Vertex : sig + (* vertices of graphs are represented by pairs of an index and a + label, and carries the sets of incoming and outgoing edges *) + (* Note: do both incoming and outgoing edges need to be labeled? *) + type label_n_neighbors = { + label: v_label; + incoming: VertexMMap.t; + outgoing: VertexMMap.t; + } + type t = index * label_n_neighbors + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + val fmt : t formatter + end = struct + type label_n_neighbors = { + label: v_label; + incoming: VertexMMap.t; + outgoing: VertexMMap.t; + } + type t = index * label_n_neighbors + + (* comparison of vertices ignores incoming/outgoing edges *) + let compare (x,{label=j}) (y,{label=k}) = + let c = Index.compare x y in if c <> 0 then c else VertexLabel.compare j k + + let equal (x,{label=j}) (y,{label=k}) = + (Index.equal x y) && (VertexLabel.equal j k) + + let hash (x,_) = + Index.hash x + + let fmt ff (i,{label}) = + Format.fprintf ff "@[%a:@ %a@]" Index.fmt i VertexLabel.fmt label + end + + + (* sets of edges to/from neighbors are represented as multi-maps from + vertices (to edge labels) *) + and VertexMMap : (ImperativeMultiMap.S + with type k = Vertex.t + and type v = EdgeLabel.t + and type vs = EdgeLabelSet.t) + = ImperativeMultiMap.Make (Vertex) (EdgeLabelSet) + + + module VertexISet = ImperativeSet.Make(Vertex) + module VertexSet = Set.Make(Vertex) + module VertexIMap = ImperativeMap.Make(Vertex) + module VertexMap = Map.Make(Vertex) + + + type label_n_neighbors = Vertex.label_n_neighbors = { + label: v_label; + incoming: VertexMMap.t; + outgoing: VertexMMap.t; + } + type vertex = index * label_n_neighbors + + + module IndexLabelSet = + ImperativeSet.Make + (struct + type t = index * v_label + let equal = equal_tup2 Index.equal VertexLabel.equal + let compare = compare_tup2 Index.compare VertexLabel.compare + end) + type roots = IndexLabelSet.t + + + (* graphs are represented by sets of vertices, which are implemented + using the isomorphic domain of multi-maps from indices to sets of + label-and-neighbor tuples, which are implemented using maps from + labels to pairs of edge sets *) + module SubVertex = ImperativeMap.Make(VertexLabel) + module Vertices = HashMap.Make(Index) + type rays = VertexMMap.t + type graph = { + verts: ((rays * rays) SubVertex.t) Vertices.t; + roots: roots + } + + + let create () = {verts= Vertices.create 31; roots= IndexLabelSet.create ()} + let clear g = Vertices.clear g.verts ; IndexLabelSet.clear g.roots + + let index_of v = fst v + let label_of v = (snd v).label + + let in_degree v = VertexMMap.length (snd v).incoming + let out_degree v = VertexMMap.length (snd v).outgoing + + let iter_preds fn v = VertexMMap.iter fn (snd v).incoming + let iter_succs fn v = VertexMMap.iter fn (snd v).outgoing + + let fold_preds fn v = VertexMMap.fold fn (snd v).incoming + let fold_succs fn v = VertexMMap.fold fn (snd v).outgoing + + let predecessors v = fold_preds (fun v e r -> (v,e)::r) v [] + let successors v = fold_succs (fun v e r -> (v,e)::r) v [] + + + let vertices_for g k = + match Vertices.tryfind g.verts k with + | None -> + [] + | Some(vs) -> + SubVertex.fold (fun label (incoming, outgoing) a -> + (k, {label; incoming; outgoing}) :: a + ) vs [] + + + let roots g = + IndexLabelSet.fold (fun (k,l) roots -> + List.fold (fun ((_,{label}) as v) roots -> + if VertexLabel.equal l label then + v :: roots + else + roots + ) (vertices_for g k) roots + ) g.roots [] + + + let mem_vertex g (k,{label=l} as v) = + L.printf 2 "mem_vertex: %a" Vertex.fmt v + ; + match Vertices.tryfind g.verts k with + | None -> false + | Some(vs) -> SubVertex.mem vs l + + + let mem_edge g src label trg = + L.printf 2 "mem_edge: %a -> %a %a" Vertex.fmt src Vertex.fmt trg EdgeLabel.fmt label ; + assert(mem_vertex g src) ; + assert(mem_vertex g trg) + ; + let eq_label = EdgeLabel.equal label + in + VertexMMap.existsi trg eq_label (snd src).outgoing + && VertexMMap.existsi src eq_label (snd trg).incoming + + + let add_edge g src label trg = + L.printf 1 "add_edge: %a -> %a %a" Vertex.fmt src Vertex.fmt trg EdgeLabel.fmt label + ; + if mem_vertex g src && mem_vertex g trg && not (mem_edge g src label trg) + then ( + VertexMMap.add (snd src).outgoing trg label ; + VertexMMap.add (snd trg).incoming src label + ) + + + let remove_edge g src label trg = + L.printf 1 "remove_edge: %a -> %a %a" Vertex.fmt src Vertex.fmt trg EdgeLabel.fmt label ; + assert( mem_edge g src label trg ); (fun () -> assert( not (mem_edge g src label trg) )) <& + let eq_label lbl = not (EdgeLabel.equal label lbl) + in + VertexMMap.filteri trg eq_label (snd src).outgoing ; + VertexMMap.filteri src eq_label (snd trg).incoming + + + let add_vertex g (k,l) = + let do_add vs = + let v = + {label= l; incoming= VertexMMap.create(); outgoing= VertexMMap.create()} + in + L.printf 1 "add_vertex: %a" Vertex.fmt (k,v) ; + SubVertex.add vs v.label (v.incoming, v.outgoing) ; + (k,v) + in + match Vertices.tryfind g.verts k with + | None -> + let vs = SubVertex.create () in + Vertices.add g.verts k vs ; + do_add vs + | Some(vs) -> + match SubVertex.tryfind vs l with + | None -> + do_add vs + | Some((i,o)) -> + L.printf 1 "add_vertex: already exists: %a: %a" Index.fmt k VertexLabel.fmt l ; + (k, {label= l; incoming= i; outgoing= o}) + + + let rec remove_vertex g ((k, {label= l; incoming= i; outgoing= o}) as v) = + L.incf 1 "( remove_vertex: %a" Vertex.fmt v ; + (fun _ -> L.decf 1 ") remove_vertex") + <& + if mem_vertex g v + && VertexMMap.is_empty i + && not (IndexLabelSet.mem g.roots (k,l)) + then ( + L.printf 1 "vertex is unreachable and not a root" + ; + VertexMMap.iter (fun u l -> remove_edge g v l u ; remove_vertex g u) o + ; + match Vertices.tryfind g.verts k with + | None -> () + | Some(vs) -> + SubVertex.remove vs l ; + if SubVertex.is_empty vs then Vertices.remove g.verts k + ) + + + let replace_vertex g new_label old_trg new_trg = + L.incf 1 "( replace_vertex: %a with %a" Vertex.fmt old_trg Vertex.fmt new_trg ; + (fun _ -> L.decf 1 ") replace_vertex") + <& + let swing_edge g src label old_trg new_trg = + if mem_edge g src label old_trg then ( + remove_edge g src label old_trg ; + add_edge g src (new_label label) new_trg + ) + in + assert( not (Vertex.equal old_trg new_trg) ); + VertexMMap.iter (fun src lab -> + swing_edge g src lab old_trg new_trg + ) (snd old_trg).incoming ; + assert( VertexMMap.is_empty (snd old_trg).incoming ); + VertexMMap.iter (fun succ lab -> + add_edge g new_trg (new_label lab) (if Vertex.equal succ old_trg then new_trg else succ) + ) (snd old_trg).outgoing ; + assert( VertexMMap.is_empty (snd old_trg).incoming ); + remove_vertex g old_trg + + + let relabel_vertex g ((k,{label}) as old_vtx) new_label = + assert( VertexLabel.equal label new_label + || invalid_arg "relabel_vertex must preserve equality of labels" ); + assert( mem_vertex g old_vtx + || invalid_arg "relabel_vertex must relabel existing vertex" ); + let vs = Vertices.find g.verts k in + let i,o = SubVertex.find vs label in + let new_vtx = (k, {label= new_label; incoming= i; outgoing= o}) in + VertexMMap.iter (fun v l -> + remove_edge g v l old_vtx ; + add_edge g v l new_vtx + ) i ; + SubVertex.add vs new_label (i,o) ; + new_vtx + + + let collapse_edge_pre g src label trg = + L.printf 1 "collapse_edge_pre: %a -> %a %a" Vertex.fmt src Vertex.fmt trg EdgeLabel.fmt label ; + assert(mem_edge g src label trg) + ; + remove_edge g src label trg + ; + VertexMMap.iter (fun u l -> + remove_edge g u l trg ; + add_edge g (if Vertex.equal u trg then src else u) l src + ) (snd trg).incoming + ; + VertexMMap.iter (fun u l -> + remove_edge g trg l u ; + add_edge g src l (if Vertex.equal u trg then src else u) + ) (snd trg).outgoing + ; + remove_vertex g trg + + + let collapse_edge_post g src label trg = + L.printf 1 "collapse_edge_post: %a -> %a %a" Vertex.fmt src Vertex.fmt trg EdgeLabel.fmt label ; + assert(mem_edge g src label trg) + ; + VertexMMap.iter (fun u l -> + remove_edge g u l src ; + add_edge g (if Vertex.equal u src then trg else u) l trg + ) (snd src).incoming + ; + remove_edge g src label trg ; + remove_vertex g src + + + let root_vertex g (k,a) = + IndexLabelSet.add g.roots (k,a.label) + + let unroot_vertex g (k,a) = + IndexLabelSet.remove g.roots (k,a.label) + + + let fold_vertices_index fn g k z = + match Vertices.tryfind g.verts k with + | None -> + z + | Some(vs) -> + SubVertex.fold (fun label (incoming,outgoing) z -> + let v = (k, {label; incoming; outgoing}) in + if mem_vertex g v + then fn v z + else z + ) vs z + + let iter_vertices_index fn g k = + fold_vertices_index (fun v () -> fn v) g k () + + + let fold_vertices fn g z = + Vertices.fold + (fun k vs z -> + SubVertex.fold + (fun l (i,o) a -> + let v = (k, {label=l; incoming=i; outgoing=o}) in + fn v a + ) vs z + ) g.verts z + + let iter_vertices fn g = + fold_vertices (fun v () -> fn v) g () + + + let fold_edges vertex_fn edge_fn g k z = + let edge_opt_fn prev_opt curr z = + match prev_opt with + | Some(prev,label) -> edge_fn (prev,label,curr) z + | None -> z + in + let memo = VertexISet.create () + in + let rec walk prev_opt curr z = + if VertexISet.mem memo curr then + edge_opt_fn prev_opt curr z + else + let z = vertex_fn curr z in + let z = edge_opt_fn prev_opt curr z in + VertexISet.add memo curr ; + VertexMMap.fold (fun next label z -> + walk (Some(curr,label)) next z + ) (snd curr).outgoing z + in + fold_vertices_index (walk None) g k z + + let iter_edges vertex_fn edge_fn g k = + fold_edges (fun v () -> vertex_fn v) (fun e () -> edge_fn e) g k () + + + let identify_vertices g = + let vertex_ids : int VertexIMap.t = VertexIMap.create () in + let count = ref 0 in + let identify_vertex v = + if not (VertexIMap.mem vertex_ids v) then ( + VertexIMap.add vertex_ids v !count ; + incr count + ) + in + iter_vertices identify_vertex g ; + vertex_ids + + + let cutpoints root = + let rec df_walk src ancestors visited cutpoints = + VertexMMap.fold (fun trg _ (visited, cutpoints) -> + if not (VertexSet.mem trg visited) then + df_walk trg (VertexSet.add trg ancestors) (VertexSet.add trg visited) cutpoints + else if not (VertexSet.mem trg ancestors) then + (visited, cutpoints) + else + (visited, VertexSet.add trg cutpoints) + ) (snd src).outgoing (visited, cutpoints) + in + let roots = VertexSet.singleton root + in + snd (df_walk root roots roots VertexSet.empty) + + + (* Breadth-first search from CLR Algorithms textbook. *) + + type visit_state = White | Grey | Black + + let bfs g start = + (* State *) + let colour : visit_state VertexIMap.t = VertexIMap.create () in + let distance : int VertexIMap.t = VertexIMap.create () in + let predecessor : (vertex * e_label) option VertexIMap.t = + VertexIMap.create () in + let grey_q : vertex Queue.t = Queue.create () in + + (* Initialize state. *) + iter_vertices + (fun v -> + VertexIMap.add colour v White ; + VertexIMap.add distance v max_int ; + VertexIMap.add predecessor v None + ) + g ; + VertexIMap.add colour start Grey ; + VertexIMap.add distance start 0 ; + VertexIMap.add predecessor start None ; + Queue.push start grey_q; + (* Main loop. *) + while (not (Queue.is_empty grey_q)) do + L.incf 2 "( bfs visit" ; (fun _ -> L.decf 2 ") bfs visit") <& + let u = Queue.peek grey_q in + L.printf 2 " u --> v, where@\nu is %a" Vertex.fmt u ; + List.iter (fun (v,tr) -> + L.printf 2 " v is %a" Vertex.fmt v ; + if (VertexIMap.find colour v = White) then ( + L.printf 2 " v is White" ; + VertexIMap.add colour v Grey ; + VertexIMap.add distance v ((VertexIMap.find distance u) + 1) ; + VertexIMap.add predecessor v (Some (u,tr)) ; + Queue.push v grey_q + ) else + L.printf 2 " v is not White" ; + ) (successors u) ; + let _ = Queue.pop grey_q in + VertexIMap.add colour u Black + done ; + (distance,predecessor) + + + (* Depth-first search *) + + let dfs_iter ?next:(next=fun () -> () ) ?forwards:(forwards=true) pre post starts = + let visited = VertexISet.create () + in + let rec dfs_visit u = + L.incf 1 "( dfs visit: u is %a" Vertex.fmt u ; (fun _ -> L.decf 1 ") dfs visit") <& + if not (VertexISet.mem visited u) then ( + VertexISet.add visited u ; + pre u ; + VertexMMap.iter (fun v _ -> + dfs_visit v + ) (if forwards then (snd u).outgoing else (snd u).incoming) ; + post u + ) + in + List.iter (fun start -> dfs_visit start ; next()) starts + + + (* Implementation from Introduction to Algorithms, Cormen et al + Section 23.5 Page 488 + *) + let scc graph = + (fun scc_map -> assert(true$> + if Config.check_scc then ( + let reaches x y = + let res = ref false in + dfs_iter (fun v -> if Vertex.equal v y then res := true) (fun _ -> ()) [x] ; + !res in + iter_vertices (fun x -> + iter_vertices (fun y -> + if not (Vertex.equal x y) then + let scc_x = VertexMap.find x scc_map in + let scc_y = VertexMap.find y scc_map in + if (scc_x == scc_y) <> (reaches x y && reaches y x) then + failwith "Graph.scc incorrect" + ) graph + ) graph + ) + ))<& + let vtxs = fold_vertices List.cons graph [] in + let rev_postorder = ref [] in + let skip = fun _ -> () in + let add_to rl = fun v -> rl := v :: !rl in + (* Get the finished times for each node *) + dfs_iter skip + (add_to rev_postorder) + vtxs ; + (* Walk backwards in reverse finished time *) + let current_scc = ref [] in + let scc_map = ref VertexMap.empty in + dfs_iter ~forwards:false + ~next:(fun () -> + (* Add each vertex in the scc to the map, with the whole SCC *) + List.iter + (fun v -> + scc_map := VertexMap.add v !current_scc !scc_map + ) + (!current_scc) ; + (* Setup next scc *) + current_scc := [] + ) + skip + (add_to current_scc) + !rev_postorder ; + !scc_map + + let dfs start = + let rev_preorder : (vertex list) ref = ref [] in + let rev_postorder : (vertex list) ref = ref [] in + let preorder_map : int VertexIMap.t = VertexIMap.create () in + let postorder_map : int VertexIMap.t = VertexIMap.create () in + let preorder_count = ref 0 in + let postorder_count = ref 0 in + dfs_iter + (fun u -> + rev_preorder := u :: !rev_preorder ; + VertexIMap.add preorder_map u !preorder_count ; + incr preorder_count + ) + (fun u -> + rev_postorder := u :: !rev_postorder ; + VertexIMap.add postorder_map u !postorder_count ; + incr postorder_count + ) + [start] ; + let preorder = List.rev (!rev_preorder) in + let postorder = List.rev (!rev_postorder) in + let preorder_num = VertexIMap.find preorder_map in + let postorder_num = VertexIMap.find postorder_map in + (preorder, postorder, preorder_num, postorder_num) + + + let dfs_revpost start = + let rev_postorder = ref [] in + let postorder_map = VertexIMap.create () in + let postorder_count = ref 0 in + dfs_iter (fun _ -> ()) (fun u -> + rev_postorder := u :: !rev_postorder ; + VertexIMap.add postorder_map u !postorder_count ; + incr postorder_count + ) [start] ; + (!rev_postorder, VertexIMap.find postorder_map) + + + (* Dominance, based on "A Simple, Fast Dominance Algorithm" (Cooper et al) *) + + let immediate_dominators start = + let rev_postorder, postorder_num = dfs_revpost start in + let nnodes = (postorder_num (List.hd rev_postorder)) + 1 in + let undefined = -1 in + let doms = Array.create nnodes undefined in + doms.(postorder_num start) <- postorder_num start + ; + let intersect i j = + let rec outer i j = + if i <> j then + let rec inner i j = + if i < j then + inner doms.(i) j + else + i + in + let i = inner i j in + let j = inner j i in + outer i j + else + i + in + outer i j + in + let not_root = List.tl rev_postorder + in + let rec build_dom_tree progress = + if progress then build_dom_tree ( + List.fold (fun n progress -> + let preds = fold_preds (fun p _ preds -> postorder_num p :: preds) n [] in + let processed_pred, other_preds = List.take (fun p -> doms.(p) <> undefined) preds in + let new_idom = + List.fold (fun p new_idom -> + if doms.(p) <> undefined then + intersect p new_idom + else + new_idom + ) other_preds processed_pred in + let b = postorder_num n in + if doms.(b) <> new_idom then ( + doms.(b) <- new_idom ; + true + ) else + progress + ) not_root false + ) + in + build_dom_tree true + ; + (doms, rev_postorder, postorder_num) + + + (* v dominates u if v is the least-common ancestor of v and u *) + let dominates doms postorder_num v u = + let i = postorder_num v + in + let rec loop j = + if j < i then + loop doms.(j) + else + j = i + in + loop (postorder_num u) + + + let dominance_frontier cfg start = + let doms, rev_postorder, postorder_num = immediate_dominators start in + let postorder = List.rev rev_postorder in + (* the ith vertex in the postorder traversal *) + let postorder_vtx i = + List.nth postorder i + in + let dfset : VertexISet.t VertexIMap.t = VertexIMap.create () in + iter_vertices + (fun n -> + VertexIMap.add dfset n (VertexISet.create ()) + ) + cfg; + iter_vertices + (fun n -> + let preds = predecessors n in + if List.length preds >= 2 then ( + let b = postorder_num n in + List.iter + (fun (p,_) -> + let runner = ref (postorder_num p) in + while (!runner <> doms.(b)) do + let runner_dfset = VertexIMap.find dfset (postorder_vtx !runner) in + VertexISet.add runner_dfset n; + runner := doms.(!runner) + done + ) + preds + ) + ) + cfg; + + (* returns the immediate dominator of n *) + let parent_of n = + try Some(postorder_vtx doms.(postorder_num n)) + with Not_found -> None + in + + (* returns the set of vertices immediately dominated by n *) + let children_of = + let map : VertexISet.t VertexIMap.t = VertexIMap.create () in + iter_vertices (fun n -> VertexIMap.add map n (VertexISet.create ())) cfg ; + iter_vertices (fun n -> + Option.iter (fun p -> + Option.iter (fun p -> + VertexISet.add p n + ) (VertexIMap.tryfind map p) + ) (parent_of n) + ) cfg ; + VertexISet.remove (VertexIMap.find map start) start; + VertexIMap.find map + in + + (* return dominator frontier set, + dominator relation, and + dominator tree functions *) + (dfset, dominates doms postorder_num, parent_of, children_of) + + (* Return the set of natural loops in [cfg] with [dominates] relation *) + + let natural_loops cfg dominates = + (* n -> h(eader) is a backedge if h dominates n *) + let backedges = fold_vertices + (fun n acc -> + let hs = List.filter + (fun (h,_) -> dominates h n) + (successors n) + in + acc @ (List.map (fun (h,_) -> (h,n)) hs) + ) + cfg [] + in + (* for each h,n pair, walk up the graph to gather the body *) + List.map + (fun (h,n) -> + let body = VertexISet.create () in + let s = Stack.create () in + VertexISet.add body h; + Stack.push n s; + while (not (Stack.is_empty s)) do + let d = Stack.pop s in + if (not (VertexISet.mem body d)) then ( + VertexISet.add body d; + List.iter + (fun (p,_) -> Stack.push p s) + (predecessors d) + ) + done; + (body,h,n) + ) + backedges + + (* Floyd-Warshall, and construct shortest-path. + From CLR Algorithms textbook. *) + type distance = Infinity | D of int + type pre = Nil | P of int + + let is_infinity d = match d with Infinity -> true | _ -> false + + (* d + d' *) + let add d d' = + match d, d' with + | Infinity,_ | _,Infinity -> Infinity + | D(i), D(i') -> D(i+i') + + (* d <= d' *) + let leq d d' = + match d, d' with + | Infinity, _ -> false + | _, Infinity -> true + | D(i), D(i') -> i <= i' + + (* SI: should return only in terms of + d : VM.key -> VM.key -> int + pre: VM.key -> VM.key -> int *) + let fw g = + + let vtx_to_i = identify_vertices g in + + let n = (VertexIMap.fold (fun _vtx i size -> max i size) vtx_to_i 0) + 1 in + + (* reverse vtx_to_i *) + let i_to_vtx = IntHMap.create n in + VertexIMap.iter (fun vtx i -> + IntHMap.add i_to_vtx i vtx + ) vtx_to_i + ; + + (* Is there an edge between the vertex indexed by i + and the one indexed by j?*) + let edge i j = + List.exists (fun i' -> + Vertex.equal i' (IntHMap.find i_to_vtx j) + ) (List.map fst (successors (IntHMap.find i_to_vtx i))) + in + + (* Matrix d (pre) uses None for infinity (NIL). *) + let d = Array.make_matrix n n Infinity in + let pre = Array.make_matrix n n Nil in + + (* initialize d *) + for i = 0 to (n-1) do + for j = 0 to (n-1) do + if (i=j) then d.(i).(j) <- D(0) + else if (i <> j) then + if (edge i j) then d.(i).(j) <- D(1) + else d.(i).(j) <- Infinity + done + done + ; + (* initialize pre *) + for i = 0 to (n-1) do + for j = 0 to (n-1) do + if (i=j || (is_infinity d.(i).(j))) then + pre.(i).(j) <- Nil + else + pre.(i).(j) <- P(i) + done + done + ; + + (* main loop *) + for k = 0 to (n-1) do + for i = 0 to (n-1) do + for j = 0 to (n-1) do + if (leq (d.(i).(j)) (add d.(i).(k) d.(k).(j))) then ( + (* SI: un-necessary *) + d.(i).(j) <- d.(i).(j) ; + pre.(i).(j) <- pre.(i).(j) ; + ) else ( + d.(i).(j) <- add d.(i).(k) d.(k).(j) ; + pre.(i).(j) <- pre.(k).(j) ; + ) + done + done + done + ; + + (* Convert [d] and [pre] matrices into (sparse) Vtx->Vtx->data maps. *) + let d' = Array.make_matrix n n None in + let pre' = Array.make_matrix n n None in + + for i = 0 to (n-1) do + for j = 0 to (n-1) do + d'.(i).(j) <- (match d.(i).(j) with + | D(d) -> Some d + | Infinity -> None ); + pre'.(i).(j) <- (match pre.(i).(j) with + | P(p) -> Some p + | Nil -> None ) + done + done + ; + (* return both [d] and [pre] matrices *) + + (vtx_to_i,i_to_vtx, d',pre') + + + let remove_unreachable g = + (fun () -> assert(true$> + let reachable = VertexISet.create () in + IndexLabelSet.iter (fun (k,label) -> + let incoming, outgoing = SubVertex.find (Vertices.find g.verts k) label in + let r = (k, {label; incoming; outgoing}) in + dfs_iter (fun v -> + VertexISet.add reachable v + ) (fun _ -> ()) [r] + ) g.roots ; + iter_vertices (fun v -> + assert( VertexISet.mem reachable v + || L.warnf "remove_unreachable failed to remove: %a" Vertex.fmt v ) + ) g + )) <& + iter_vertices (remove_vertex g) g + + + let copy g0 src = + let g = create () + in + let m = + fold_edges + (fun v m -> + VertexMap.add v (add_vertex g (index_of v, label_of v)) m + ) + (fun (u,l,v) m -> + match VertexMap.tryfind u m, VertexMap.tryfind v m with + | Some(u'), Some(v') -> + add_edge g u' l v'; m + | _ -> + m + ) + g0 + (index_of src) + VertexMap.empty + in + (m, g) + + + let slice src trg g0 = + let vtx_to_id,_, distance,_ = fw g0 + in + let trg_id = VertexIMap.find vtx_to_id trg + in + let g = create () + in + let m = + fold_edges + (fun v m -> + assert( distance.(VertexIMap.find vtx_to_id src).(VertexIMap.find vtx_to_id v) <> None ); + if distance.(VertexIMap.find vtx_to_id v).(trg_id) <> None then + VertexMap.add v (add_vertex g (index_of v, label_of v)) m + else + m + ) + (fun (u,l,v) m -> + match VertexMap.tryfind u m, VertexMap.tryfind v m with + | Some(u'), Some(v') -> + add_edge g u' l v'; m + | _ -> + m + ) + g0 + (index_of src) + VertexMap.empty + in + (m, g) + + + (* Conversion to dot format. *) + + let calculate_margin len = + let rec loop height width = + if width /. height > Config.margin_frac then + loop (height +. 1.) (width /. 2.) + else + int_of_float width + in + if len <= 40 then 40 else + loop 1. (float_of_int len) + + let reprint msg = + let src_buf = Buffer.create 128 in + let ff = Format.formatter_of_buffer src_buf in + Format.pp_set_margin ff max_int ; + msg ff ; + Format.pp_print_flush ff () ; + + let len = Buffer.length src_buf in + let src_buf = Buffer.create len in + let ff = Format.formatter_of_buffer src_buf in + Format.pp_set_margin ff (calculate_margin len) ; + msg ff ; + Format.pp_print_flush ff () ; + + let dst_buf = Buffer.create len in + for ind = 0 to Buffer.length src_buf - 1 do + match Buffer.nth src_buf ind with + | '\n' -> Buffer.add_string dst_buf "\\l" + | '\\' -> Buffer.add_string dst_buf "\\\\" + | '\"' -> Buffer.add_string dst_buf "\\\"" + | char -> Buffer.add_char dst_buf char + done ; + Buffer.contents dst_buf + + let writers g out = + let id = + let m = identify_vertices g in + VertexIMap.find m + in + let write_vertex v = + let msg v = reprint (fun ff -> Vertex.fmt ff v) in + Printf.bprintf out "%i [shape=box,label=\"v %i: %s\\l\"]\n" (id v) (id v) (msg v) + in + let write_edge (src,lab,trg) = + let msg lab = reprint (fun ff -> EdgeLabel.fmt ff lab) in + Printf.bprintf out "%i -> %i [label=\"%s\\l\"]\n" (id src) (id trg) (msg lab) + in + (write_vertex, write_edge, id) + + let write_dot_header out = + Printf.bprintf out "digraph g {\n" ; + if Config.font <> "" then ( + Printf.bprintf out "graph [fontname=\"%s\"]\n" Config.font ; + Printf.bprintf out "node [fontname=\"%s\"]\n" Config.font ; + Printf.bprintf out "edge [fontname=\"%s\"]\n" Config.font ; + ) + + let write_dot_footer out = + Printf.bprintf out "}\n" + + (* cfg with dominator tree *) + let cfg_write_dot cfg children_of k out = + let write_vertex, write_edge, id = writers cfg out in + write_dot_header out ; + iter_edges write_vertex write_edge cfg k ; + (* dominator tree edges *) + iter_vertices (fun n -> + VertexISet.iter (fun m -> + Printf.bprintf out "%i -> %i [dir=none, weight=3, penwidth=3, color=\"#660000\"]\n" (id n) (id m)) + (children_of n); + ) cfg; + write_dot_footer out + + let write_dot g k out = + let write_vertex, write_edge, _ = writers g out + in + write_dot_header out ; + iter_edges write_vertex write_edge g k ; + write_dot_footer out + + + let write_dot_partitioned fn g roots out = + let write_vertex, write_edge, _ = writers g out + in + let vs = ref [] in + List.iter (iter_edges (fun v -> vs := v :: !vs) (fun _ -> ()) g) roots ; + let partitions = + List.classify (fun x y -> + Option.equal (fun a b -> fst a = fst b) + (fn (index_of x)) (fn (index_of y)) + ) !vs in + write_dot_header out ; + List.iter (fun vs -> + match fn (index_of (List.hd vs)) with + | None -> () + | Some(name,msg) -> + Printf.bprintf out "subgraph cluster%s {\nlabel=\"%s\"\n" name (reprint msg) ; + List.iter write_vertex vs ; + Printf.bprintf out "}\n" + ) partitions ; + List.iter (fun root -> + iter_edges + (fun v -> + match fn (index_of v) with + | Some _ -> () + | None -> write_vertex v + ) + write_edge + g root + ) roots ; + write_dot_footer out + +end diff --git a/src/Graph.mli b/src/Graph.mli new file mode 100644 index 0000000..0672e6b --- /dev/null +++ b/src/Graph.mli @@ -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 + ) diff --git a/src/Graph_sig.ml b/src/Graph_sig.ml new file mode 100644 index 0000000..76b6079 --- /dev/null +++ b/src/Graph_sig.ml @@ -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 diff --git a/src/HashCons.ml b/src/HashCons.ml new file mode 100644 index 0000000..f06b532 --- /dev/null +++ b/src/HashCons.ml @@ -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 diff --git a/src/HashCons.mli b/src/HashCons.mli new file mode 100644 index 0000000..a2258c0 --- /dev/null +++ b/src/HashCons.mli @@ -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 diff --git a/src/HeapAbstraction.ml b/src/HeapAbstraction.ml new file mode 100644 index 0000000..d4d9148 --- /dev/null +++ b/src/HeapAbstraction.ml @@ -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 "@[abs_ls: creating list %a, replace:@ %t@]@ @[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 diff --git a/src/HeapAbstraction.mli b/src/HeapAbstraction.mli new file mode 100644 index 0000000..5639376 --- /dev/null +++ b/src/HeapAbstraction.mli @@ -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 diff --git a/src/HeapGraph.ml b/src/HeapGraph.ml new file mode 100644 index 0000000..2dc6b70 --- /dev/null +++ b/src/HeapGraph.ml @@ -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 "@[[%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 diff --git a/src/HeapGraph.mli b/src/HeapGraph.mli new file mode 100644 index 0000000..350eb27 --- /dev/null +++ b/src/HeapGraph.mli @@ -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 diff --git a/src/Hooks.ml b/src/Hooks.ml new file mode 100644 index 0000000..c1f3078 --- /dev/null +++ b/src/Hooks.ml @@ -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 diff --git a/src/Hooks.mli b/src/Hooks.mli new file mode 100644 index 0000000..61bb4a7 --- /dev/null +++ b/src/Hooks.mli @@ -0,0 +1,6 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Hooks for very applicaton-specific behavior. *) + + +val var_name : string -> string diff --git a/src/Initialize.ml b/src/Initialize.ml new file mode 100644 index 0000000..a49c03f --- /dev/null +++ b/src/Initialize.ml @@ -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 diff --git a/src/Initialize.mli b/src/Initialize.mli new file mode 100644 index 0000000..0a37649 --- /dev/null +++ b/src/Initialize.mli @@ -0,0 +1,8 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Program + + +val register : (Prog.t -> unit) -> unit + +val initialize : Prog.t -> unit diff --git a/src/Inline.ml b/src/Inline.ml new file mode 100644 index 0000000..20596c3 --- /dev/null +++ b/src/Inline.ml @@ -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} diff --git a/src/Inline.mli b/src/Inline.mli new file mode 100644 index 0000000..f4498eb --- /dev/null +++ b/src/Inline.mli @@ -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 diff --git a/src/Instrumentation.ml b/src/Instrumentation.ml new file mode 100644 index 0000000..931da50 --- /dev/null +++ b/src/Instrumentation.ml @@ -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 "@[? " " .@]@ " + + + +(*============================================================================ + 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:@ @[%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@[\ + 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)) diff --git a/src/Instrumentation.mli b/src/Instrumentation.mli new file mode 100644 index 0000000..7881b78 --- /dev/null +++ b/src/Instrumentation.mli @@ -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 diff --git a/src/Interproc.ml b/src/Interproc.ml new file mode 100644 index 0000000..008eb80 --- /dev/null +++ b/src/Interproc.ml @@ -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 "@[%s summary:@ @[%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@[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@[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 "@[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 "@[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@[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@[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@[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@[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 diff --git a/src/Interproc.mli b/src/Interproc.mli new file mode 100644 index 0000000..69ea1c6 --- /dev/null +++ b/src/Interproc.mli @@ -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 diff --git a/src/Interproc_sig.ml b/src/Interproc_sig.ml new file mode 100644 index 0000000..befdcab --- /dev/null +++ b/src/Interproc_sig.ml @@ -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 diff --git a/src/Library.ml b/src/Library.ml new file mode 100644 index 0000000..305e700 --- /dev/null +++ b/src/Library.ml @@ -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 diff --git a/src/Library.mli b/src/Library.mli new file mode 100644 index 0000000..6b0c485 --- /dev/null +++ b/src/Library.mli @@ -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 diff --git a/src/Library/NSArray.ml b/src/Library/NSArray.ml new file mode 100644 index 0000000..bb6f0db --- /dev/null +++ b/src/Library/NSArray.ml @@ -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 diff --git a/src/Library/NSArray.mli b/src/Library/NSArray.mli new file mode 100644 index 0000000..de61cb4 --- /dev/null +++ b/src/Library/NSArray.mli @@ -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 diff --git a/src/Library/NSBinaryRelation.ml b/src/Library/NSBinaryRelation.ml new file mode 100644 index 0000000..dc6c7d3 --- /dev/null +++ b/src/Library/NSBinaryRelation.ml @@ -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 diff --git a/src/Library/NSBinaryRelation.mli b/src/Library/NSBinaryRelation.mli new file mode 100644 index 0000000..7dbfe0e --- /dev/null +++ b/src/Library/NSBinaryRelation.mli @@ -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 diff --git a/src/Library/NSHashMap.ml b/src/Library/NSHashMap.ml new file mode 100644 index 0000000..23892f4 --- /dev/null +++ b/src/Library/NSHashMap.ml @@ -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) diff --git a/src/Library/NSHashMap.mli b/src/Library/NSHashMap.mli new file mode 100644 index 0000000..9751fd8 --- /dev/null +++ b/src/Library/NSHashMap.mli @@ -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) diff --git a/src/Library/NSHashMultiMap.ml b/src/Library/NSHashMultiMap.ml new file mode 100644 index 0000000..173a45f --- /dev/null +++ b/src/Library/NSHashMultiMap.ml @@ -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) diff --git a/src/Library/NSHashMultiMap.mli b/src/Library/NSHashMultiMap.mli new file mode 100644 index 0000000..a504b1f --- /dev/null +++ b/src/Library/NSHashMultiMap.mli @@ -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 diff --git a/src/Library/NSHashSet.ml b/src/Library/NSHashSet.ml new file mode 100644 index 0000000..aaec45c --- /dev/null +++ b/src/Library/NSHashSet.ml @@ -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 diff --git a/src/Library/NSHashSet.mli b/src/Library/NSHashSet.mli new file mode 100644 index 0000000..00175ae --- /dev/null +++ b/src/Library/NSHashSet.mli @@ -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 diff --git a/src/Library/NSHashtbl.ml b/src/Library/NSHashtbl.ml new file mode 100644 index 0000000..80d37a1 --- /dev/null +++ b/src/Library/NSHashtbl.ml @@ -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 diff --git a/src/Library/NSHashtbl.mli b/src/Library/NSHashtbl.mli new file mode 100644 index 0000000..640e26c --- /dev/null +++ b/src/Library/NSHashtbl.mli @@ -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 diff --git a/src/Library/NSImperativeMap.ml b/src/Library/NSImperativeMap.ml new file mode 100644 index 0000000..ac4bcfe --- /dev/null +++ b/src/Library/NSImperativeMap.ml @@ -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) diff --git a/src/Library/NSImperativeMap.mli b/src/Library/NSImperativeMap.mli new file mode 100644 index 0000000..6685258 --- /dev/null +++ b/src/Library/NSImperativeMap.mli @@ -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 diff --git a/src/Library/NSImperativeMultiMap.ml b/src/Library/NSImperativeMultiMap.ml new file mode 100644 index 0000000..bdc15cc --- /dev/null +++ b/src/Library/NSImperativeMultiMap.ml @@ -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 diff --git a/src/Library/NSImperativeMultiMap.mli b/src/Library/NSImperativeMultiMap.mli new file mode 100644 index 0000000..bf0ba82 --- /dev/null +++ b/src/Library/NSImperativeMultiMap.mli @@ -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 diff --git a/src/Library/NSImperativeSet.ml b/src/Library/NSImperativeSet.ml new file mode 100644 index 0000000..0b7744f --- /dev/null +++ b/src/Library/NSImperativeSet.ml @@ -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 diff --git a/src/Library/NSImperativeSet.mli b/src/Library/NSImperativeSet.mli new file mode 100644 index 0000000..4589369 --- /dev/null +++ b/src/Library/NSImperativeSet.mli @@ -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 diff --git a/src/Library/NSIndexedSet.ml b/src/Library/NSIndexedSet.ml new file mode 100644 index 0000000..0114d15 --- /dev/null +++ b/src/Library/NSIndexedSet.ml @@ -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 diff --git a/src/Library/NSIndexedSet.mli b/src/Library/NSIndexedSet.mli new file mode 100644 index 0000000..9806504 --- /dev/null +++ b/src/Library/NSIndexedSet.mli @@ -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 diff --git a/src/Library/NSLib.ml b/src/Library/NSLib.ml new file mode 100644 index 0000000..62a1aed --- /dev/null +++ b/src/Library/NSLib.ml @@ -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 diff --git a/src/Library/NSLib.mli b/src/Library/NSLib.mli new file mode 100644 index 0000000..eb89a32 --- /dev/null +++ b/src/Library/NSLib.mli @@ -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 diff --git a/src/Library/NSList.ml b/src/Library/NSList.ml new file mode 100644 index 0000000..05e2595 --- /dev/null +++ b/src/Library/NSList.ml @@ -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 diff --git a/src/Library/NSList.mli b/src/Library/NSList.mli new file mode 100644 index 0000000..b844395 --- /dev/null +++ b/src/Library/NSList.mli @@ -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 diff --git a/src/Library/NSMap.ml b/src/Library/NSMap.ml new file mode 100644 index 0000000..1a94ffc --- /dev/null +++ b/src/Library/NSMap.ml @@ -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) diff --git a/src/Library/NSMap.mli b/src/Library/NSMap.mli new file mode 100644 index 0000000..d4978b5 --- /dev/null +++ b/src/Library/NSMap.mli @@ -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 diff --git a/src/Library/NSMultiIndexedMultiSet.ml b/src/Library/NSMultiIndexedMultiSet.ml new file mode 100644 index 0000000..64fa8ab --- /dev/null +++ b/src/Library/NSMultiIndexedMultiSet.ml @@ -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 diff --git a/src/Library/NSMultiIndexedMultiSet.mli b/src/Library/NSMultiIndexedMultiSet.mli new file mode 100644 index 0000000..0cf47d5 --- /dev/null +++ b/src/Library/NSMultiIndexedMultiSet.mli @@ -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 diff --git a/src/Library/NSMultiIndexedSet.ml b/src/Library/NSMultiIndexedSet.ml new file mode 100644 index 0000000..0539b69 --- /dev/null +++ b/src/Library/NSMultiIndexedSet.ml @@ -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 diff --git a/src/Library/NSMultiIndexedSet.mli b/src/Library/NSMultiIndexedSet.mli new file mode 100644 index 0000000..fe4ee89 --- /dev/null +++ b/src/Library/NSMultiIndexedSet.mli @@ -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 diff --git a/src/Library/NSMultiMap.ml b/src/Library/NSMultiMap.ml new file mode 100644 index 0000000..4cafea3 --- /dev/null +++ b/src/Library/NSMultiMap.ml @@ -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 diff --git a/src/Library/NSMultiMap.mli b/src/Library/NSMultiMap.mli new file mode 100644 index 0000000..8a29caf --- /dev/null +++ b/src/Library/NSMultiMap.mli @@ -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 diff --git a/src/Library/NSMultiSet.ml b/src/Library/NSMultiSet.ml new file mode 100644 index 0000000..cc964cd --- /dev/null +++ b/src/Library/NSMultiSet.ml @@ -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 diff --git a/src/Library/NSMultiSet.mli b/src/Library/NSMultiSet.mli new file mode 100644 index 0000000..762dfa9 --- /dev/null +++ b/src/Library/NSMultiSet.mli @@ -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 diff --git a/src/Library/NSOption.ml b/src/Library/NSOption.ml new file mode 100644 index 0000000..a84d91c --- /dev/null +++ b/src/Library/NSOption.ml @@ -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) diff --git a/src/Library/NSOption.mli b/src/Library/NSOption.mli new file mode 100644 index 0000000..decaf67 --- /dev/null +++ b/src/Library/NSOption.mli @@ -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. *) diff --git a/src/Library/NSPolyHashMap.ml b/src/Library/NSPolyHashMap.ml new file mode 100644 index 0000000..3ca4d56 --- /dev/null +++ b/src/Library/NSPolyHashMap.ml @@ -0,0 +1,9 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open NSHashtbl + + +module PolyHMap = struct + include Hashtbl + let add = replace +end diff --git a/src/Library/NSPolyHashMap.mli b/src/Library/NSPolyHashMap.mli new file mode 100644 index 0000000..39f57f6 --- /dev/null +++ b/src/Library/NSPolyHashMap.mli @@ -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 diff --git a/src/Library/NSPolySet.ml b/src/Library/NSPolySet.ml new file mode 100644 index 0000000..abcb4be --- /dev/null +++ b/src/Library/NSPolySet.ml @@ -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 diff --git a/src/Library/NSPolySet.mli b/src/Library/NSPolySet.mli new file mode 100644 index 0000000..e194641 --- /dev/null +++ b/src/Library/NSPolySet.mli @@ -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 diff --git a/src/Library/NSSet.ml b/src/Library/NSSet.ml new file mode 100644 index 0000000..4b6f7be --- /dev/null +++ b/src/Library/NSSet.ml @@ -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) diff --git a/src/Library/NSSet.mli b/src/Library/NSSet.mli new file mode 100644 index 0000000..393d157 --- /dev/null +++ b/src/Library/NSSet.mli @@ -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 diff --git a/src/Library/NSSortedList.ml b/src/Library/NSSortedList.ml new file mode 100644 index 0000000..c2a5b42 --- /dev/null +++ b/src/Library/NSSortedList.ml @@ -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 diff --git a/src/Library/NSSortedList.mli b/src/Library/NSSortedList.mli new file mode 100644 index 0000000..a9d0038 --- /dev/null +++ b/src/Library/NSSortedList.mli @@ -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 diff --git a/src/Library/NSString.ml b/src/Library/NSString.ml new file mode 100644 index 0000000..113ad2c --- /dev/null +++ b/src/Library/NSString.ml @@ -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 diff --git a/src/Library/NSString.mli b/src/Library/NSString.mli new file mode 100644 index 0000000..97c97d2 --- /dev/null +++ b/src/Library/NSString.mli @@ -0,0 +1,9 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + + +(** Operations on strings. See also standard + {{:file:../../../doc/ocaml%20manual/libref/String.html}String}. *) +module String : sig + include module type of String + val filteri : (int -> char -> bool) -> string -> string +end diff --git a/src/Library/NSTuple.ml b/src/Library/NSTuple.ml new file mode 100644 index 0000000..6a0e478 --- /dev/null +++ b/src/Library/NSTuple.ml @@ -0,0 +1,13 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open NSList + + +module Tuple = struct + + let map2 f g (x,y) = f x, g y + let map3 fn fo fp (x,y,z) = fn x, fo y, fp z + + let fmt fn ff = Format.fprintf ff "@[(%a)@]" (List.fmt ",@," fn) + +end diff --git a/src/Library/NSTuple.mli b/src/Library/NSTuple.mli new file mode 100644 index 0000000..eaaa261 --- /dev/null +++ b/src/Library/NSTuple.mli @@ -0,0 +1,11 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open NSLib + + +(** Operations on tuples. *) +module Tuple : sig + val map2 : ('a->'b) -> ('c->'d) -> 'a*'c -> 'b*'d + val map3 : ('a->'b) -> ('c->'d) -> ('e->'f) -> 'a*'c*'e -> 'b*'d*'f + val fmt : 'a formatter -> 'a list formatter +end diff --git a/src/Livevars.ml b/src/Livevars.ml new file mode 100644 index 0000000..f6594e2 --- /dev/null +++ b/src/Livevars.ml @@ -0,0 +1,177 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library + +open Variable +open Expression +open SymbolicHeap +open Program +module I = Inst +module C = Cmnd +module K = ControlPoint + + +(* remove the variables assigned to by c from rs, and extend rs with the variables read by c *) +let rec inst_trans i rs = + let open Inst in + match i with + | Nop -> + rs + | Kill(vs) -> + Vars.diff rs vs + | Move(x,e) when Vars.mem x rs -> + Vars.union (Exp.fv e) (Vars.remove x rs) + | Move _ -> + rs + | Cast(x,_,e) + | Load(x,e) + | Alloc(x,e) -> + Vars.union (Exp.fv e) (Vars.remove x rs) + | Store(e,f) -> + Vars.union (Vars.union (Exp.fv e) (Exp.fv f)) rs + | Free(e) + | Assert(e) + | Assume(e) -> + Vars.union (Exp.fv e) rs + | Generic({ghosts; pre; insts; post}) -> + let pre_vars = Vars.diff (XSH.fv pre) ghosts in + let post_vars = Vars.diff (XSH.fv post) ghosts in + Vars.union pre_vars + (List.fold inst_trans insts + (Vars.union post_vars rs)) + +(* remove the variables assigned to by ct from rs, and extend rs with the variables read by ct *) +let cmnd_trans globals procs c rs = + let open Cmnd in + let add_accessed pid = + Vars.union (try (Proc.IdHMap.find procs pid).Proc.accessed with Not_found -> globals) + in + let cmnd_call cmnd_proc {Call.proc; actuals; areturn; targets} rs = + rs |> + cmnd_proc proc |> + List.fold Vars.add actuals |> + Option.fold (fun ret rs -> Vars.remove ret rs) areturn |> + List.fold add_accessed targets + in + match c with + | Inst{I.desc} -> inst_trans desc rs + | Call(call) -> cmnd_call (fun _ rs -> rs) call rs + | ICall(call) -> cmnd_call (fun fp rs -> Vars.union (Exp.fv fp) rs) call rs + + +let lift_trans f = fun e x y -> + let y_new = + match x with + | None -> f e Vars.empty + | Some x -> f e x in + match y with + | None -> + Some y_new + | Some y -> + if Vars.subset y_new y then + None + else + Some (Vars.union y_new y) + +(* Need to make this walk bits that can't reach the end *) +let graph_pred_traverse_fixedpoint entry start start_val trans upd graph = + let module V = CFG.VertexIMap in + let module Q = Queue in + let live = V.create () in + let get_live n = V.tryfind live n in + let workset = Q.create () in + CFG.iter_vertices (fun x -> Q.push x workset) graph ; + Q.push start workset ; + V.add live start start_val ; + while not (Q.is_empty workset) do + let n = Q.pop workset in + let v_post = get_live n in + CFG.iter_preds (fun n' e -> + let v_pre = get_live n' in + match trans e v_post v_pre with + | Some(v_new) -> + V.add live n' v_new ; + Q.push n' workset + | None -> + () + ) n ; + done ; + let get_live n = try V.find live n with Not_found -> Vars.empty in + CFG.dfs_iter + (fun prev -> + CFG.iter_succs (fun curr label -> + upd prev (get_live prev) label curr (get_live curr) + ) prev + ) + (fun _ -> ()) + [entry] + +let insert_kill cfg prev cmnd curr died live = + match cmnd with + | C.Inst {I.desc= I.Move(x,_); pos} when Vars.mem x died -> + (* Replace moves to variables that kill their lhs with nops *) + CFG.remove_edge cfg prev cmnd curr ; + let inst' = C.Inst (I.mk I.Nop pos) in + CFG.add_edge cfg prev inst' curr + + | C.Inst {I.desc= I.Move(x,_); pos} when not (Vars.mem x live) -> + (* Replace moves to dead variables with kills *) + CFG.remove_edge cfg prev cmnd curr ; + let inst' = C.Inst (I.mk (I.Kill (Vars.add x died)) pos) in + CFG.add_edge cfg prev inst' curr + + | C.Inst {I.desc= I.Kill(kill); pos} -> + (* If edge is a kill *) + if Vars.subset died kill then + (* Do nothing as the kill will already happen *) + () + else ( + (* Update the kill to include the dead vars *) + CFG.remove_edge cfg prev cmnd curr ; + let inst' = C.Inst (I.mk (I.Kill (Vars.union died kill)) pos) in + CFG.add_edge cfg prev inst' curr + ) + | _ -> + (* Perform a little look ahead *) + let a = Vars.inters (List.map (fun (_,ct) -> C.mv ct) (CFG.successors curr)) in + let died = Vars.diff died a in + (* Otherwise split the edge into the original, and a kill *) + if Vars.is_empty died then + () + else + (* splitting prev -> curr into prev -> fresh -> curr + sort of fresh will be Return if sort of curr is, otherwise None + in Return case, must relabel curr as fresh will be the return site *) + let sort, curr = + if K.sort curr = Some(K.Return) then + let curr = CFG.relabel_vertex cfg curr (K.set_sort (CFG.label_of curr) None) in + (Some(K.Return), curr) + else + (None, curr) in + + let fresh = CFG.add_vertex cfg (K.mk_label ?sort (K.pos curr) (K.proc curr)) in + + let kill = C.Inst (I.mk (I.Kill died) (K.pos prev)) in + + CFG.remove_edge cfg prev cmnd curr ; + CFG.add_edge cfg prev cmnd fresh ; + CFG.add_edge cfg fresh kill curr ; + () + + +let upd_edge cfg prev live_prev inst curr live_curr = + let died = Vars.diff (Vars.union (C.mv inst) live_prev) live_curr in + insert_kill cfg prev inst curr died live_curr + +let liveness_proc globals procs _ {Proc.formals; freturn; cfg; entry; exit} = + graph_pred_traverse_fixedpoint entry exit + (Option.fold Vars.add freturn (List.fold Vars.add formals globals)) + (lift_trans (cmnd_trans globals procs)) + (upd_edge cfg) + cfg + + +let liveness_prog ({Prog.globals; procs} as prog) = + if Config.optimize_liveness then + Prog.iter_procs (fun p -> liveness_proc globals procs p) prog ; + prog diff --git a/src/Livevars.mli b/src/Livevars.mli new file mode 100644 index 0000000..c23ecd5 --- /dev/null +++ b/src/Livevars.mli @@ -0,0 +1,6 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Program + + +val liveness_prog : Prog.t -> Prog.t diff --git a/src/Log.ml b/src/Log.ml new file mode 100644 index 0000000..fcb1b48 --- /dev/null +++ b/src/Log.ml @@ -0,0 +1,146 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Debug message logging *) + +open Library + + +(* For each channel, there is one indent ref, but multiple flag refs. *) +type log = { + flag: int ref; + indent: int ref; + formatter: Format.formatter; + buffer: Buffer.t; + channel: out_channel; +} + + +let set_indent log i = + log.indent := i ; + assert (!(log.indent) >= 0) ; + Format.pp_set_margin log.formatter (Config.margin - 2 * (!(log.indent) + 2)) + +let inc_indent log = set_indent log (!(log.indent) + 1) + + +let flush_and_reprint log () = + let pr_indent () = + for _i = !(log.indent) downto 0 do output_string log.channel "| " done + in + Format.pp_print_flush log.formatter () ; + set_indent log !(log.indent) ; + let n = Buffer.length log.buffer - 1 in + if n >= 0 then ( + let prev = ref (-1) in + for curr = 0 to n do + if Buffer.nth log.buffer curr = '\n' then ( + pr_indent () ; + output_string log.channel + (Buffer.sub log.buffer (!prev + 1) (curr - !prev)) ; + prev := curr ; + ) + done; + if !prev < n then ( + pr_indent () ; + output_string log.channel + (Buffer.sub log.buffer (!prev + 1) (n - !prev)) ; + output_string log.channel "\n" ; + flush log.channel ; + ) + ) ; + Buffer.clear log.buffer + + +let printf log vlevel = + if vlevel = 0 || vlevel <= !(log.flag) + then Format.kfprintf (fun _ -> flush_and_reprint log ()) log.formatter + else Format.ifprintf log.formatter + + +let incf log vlevel = + if vlevel = 0 || vlevel <= !(log.flag) then + Format.kfprintf (fun _ -> + flush_and_reprint log () ; + inc_indent log + ) log.formatter + else + Format.ifprintf log.formatter + +let resetf log vlevel ilevel fmt = + (* decrement indent before printing anything, but after accepting all args *) + printf log vlevel ("%t"^^fmt) (fun _ -> set_indent log ilevel) + +let decf log vlevel fmt = + resetf log vlevel (!(log.indent) - 1) fmt + + +let latch log = + !(log.indent) + +let latch_incf log vlevel start_msg fmt x = + let save_indent = !(log.indent) in + incf log vlevel start_msg fmt x ; + save_indent + + +let warnf log = + Format.kfprintf (fun _ -> flush_and_reprint log () ; true) log.formatter + + +let shift_verb verbose shift thunk = + let save = !verbose in + verbose := !verbose - shift; + let res = thunk() in + verbose := save; + res + + +module type LOG = sig + val printf : int -> ('a,Format.formatter,unit)format -> 'a + val incf : int -> ('a,Format.formatter,unit)format -> 'a + val decf : int -> ('a,Format.formatter,unit)format -> 'a + + val warnf : ('a,Format.formatter,unit,bool)format4 -> 'a + + val latch : unit -> int + val latch_incf : int -> 'a format_str -> 'a formatter -> 'a -> int + val resetf : int -> int -> ('a,Format.formatter,unit)format -> 'a + + val shift_verb : int -> (unit -> 'a) -> 'a +end + + +let mk_raw channel = + let indent = ref 0 in + let buffer = Buffer.create 512 in + let formatter = Format.formatter_of_buffer buffer in + fun flag -> + let log = {flag; indent; formatter; buffer; channel} in + set_indent log 0 ; + let module L = struct + let printf l x = printf log l x + let incf l x = incf log l x + let decf l x = decf log l x + let warnf x = warnf log x + let latch () = latch log + let resetf l x = resetf log l x + let latch_incf l m x = latch_incf log l m x + let shift_verb l t = shift_verb flag l t + end in + (module L : LOG) + +let mk channel = + let mkL = mk_raw channel in + fun flag -> + let module L = (val mkL flag : LOG) in + (module struct + include L + let printf l x = printf l ("@["^^x^^"@]") + let incf l x = incf l ("@["^^x^^"@]") + let decf l x = decf l ("@["^^x^^"@]") + let warnf x = warnf ("@["^^x^^"@]") + end : LOG) + +let raw = mk_raw Pervasives.stdout + +let std = mk Pervasives.stdout diff --git a/src/Log.mli b/src/Log.mli new file mode 100644 index 0000000..054c893 --- /dev/null +++ b/src/Log.mli @@ -0,0 +1,28 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Debug message logging *) + +open Library + + +module type LOG = sig + val printf : int -> ('a,Format.formatter,unit)format -> 'a + val incf : int -> ('a,Format.formatter,unit)format -> 'a + val decf : int -> ('a,Format.formatter,unit)format -> 'a + + val warnf : ('a,Format.formatter,unit,bool)format4 -> 'a + + val latch : unit -> int + val latch_incf : int -> 'a format_str -> 'a formatter -> 'a -> int + val resetf : int -> int -> ('a,Format.formatter,unit)format -> 'a + + val shift_verb : int -> (unit -> 'a) -> 'a +end + +val mk_raw : out_channel -> int ref -> (module LOG) + +val raw : int ref -> (module LOG) + +val mk : out_channel -> int ref -> (module LOG) + +val std : int ref -> (module LOG) diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..2fb7f24 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,305 @@ +# Copyright (c) Microsoft Corporation. All rights reserved. + +# Detect operating system, architecture, and number of processors +ifeq (${OS},Windows_NT) + ARCH=x86 + NPROCS:=$(subst NumberOfLogicalProcessors=,,$(strip $(shell wmic cpu get NumberOfLogicalProcessors /value))) +else + OS := $(shell uname -s) + ARCH := $(shell uname -m) +ifeq ($(OS), Linux) + NPROCS:=$(shell nproc) +endif +ifeq ($(OS), Darwin) + NPROCS:=$(subst hw.ncpu: ,,$(shell sysctl hw.ncpu)) +endif +endif + +ifeq ($(OS), Windows_NT) +# path to the root of the SLAyer source, in windows format since it is passed to the linker +SRC=$(shell cygpath -m $(CURDIR)) +EXE=.exe +OSBUILDFLAGS=-lib esp -lflags "-cclib /link/NODEFAULTLIB:LIBCMT" +Frontend_byte=Frontend.byte +Frontend_native=Frontend.native +else +SRC=$(CURDIR) +endif + + +# To build SLAyer execute: +# make +# To build all unit tests execute: +# make test +# To build a set of unit tests ... execute: +# make TEST={.ml ... .ml} test +# +# By default set TEST to the set of ml files in StandAlone: +TEST:=$(notdir $(wildcard $(SRC)/UnitTests/StandAlone/*.ml)) + +# To build a single module execute: +# make M= module +M= + +SLAyer_CFLAGS?=-cflags -annot + +# Note: ocamlbuild seems not to have a rule for building .cmi, .cmx, and .o +# from .ml directly, and instead builds .cmo and .cmi from .ml and then +# builds .cmx and .o from .cmi and .ml, thereby compiling everything twice. + + +# path to the Z3 source directory, build directory, and the subdirectory for the compiled OCaml interface +# these are in unix format since they are used in make rules where windows' colons are invalid +Z3_SRC=$(CURDIR)/../tools/Z3/src +Z3_BLD=$(Z3_SRC)/../build +Z3_BLD_ML=$(Z3_BLD)/api/ml +# and in windows format for the linker +Z3_BLD_ML_WIN=$(SRC)/../tools/Z3/build/api/ml + +# path to the ESP compiled OCaml interface, in windows format for the linker +ESP_BLD=$(SRC)/../tools/esp/ocaml + +# name of directory to contain SLAyer compiled code +BUILD=_build/$(OS)/$(ARCH) + +# common ocamlbuild options +OCAMLBUILD= \ + ocamlbuild \ + -j $(NPROCS) -no-links -build-dir $(BUILD) \ + -tag bin_annot \ + -cflags "-short-paths -w +6+7+27+29+32..39+41+44+45" \ + -cflags -I,$(ESP_BLD) -lflags -I,$(ESP_BLD) \ + -cflags -I,$(Z3_BLD_ML_WIN) -lflags -I,$(Z3_BLD_ML_WIN) \ + $(SLAyer_CFLAGS) \ + -Is Library,contaminated,UnitTests,UnitTests/StandAlone \ + -libs str,unix,z3 \ + $(OSBUILDFLAGS) + + +## SLAyer targets + +default: dbg + +help: + @cat README + +all: dbg opt #doc + + +dbg: $(Z3_BLD_ML)/z3.cma $(Z3_BLD_ML)/z3.cmxa ../bin version + @echo "======== building SLAyer debug (byte & native) code ========" + $(OCAMLBUILD) -tag debug \ + slayer.byte $(Frontend_byte) slayer.native $(Frontend_native) + -@cp -p $(BUILD)/slayer.native ../bin/slayer$(EXE) + -@if test -f $(BUILD)/Frontend.native; then cp -p $(BUILD)/Frontend.native ../bin/frontend$(EXE); fi + + +opt: $(Z3_BLD_ML)/z3.cmxa ../bin version + @echo "======== building SLAyer optimized (native) code ========" + $(OCAMLBUILD) -build-dir $(BUILD)_opt -tag debug -cflags -noassert,-unsafe -lflags -noassert,-unsafe \ + slayer.native $(Frontend_native) + -@cp -p $(BUILD)_opt/slayer.native ../bin/slayer$(EXE) + -@if test -f $(BUILD)_opt/Frontend.native; then cp -p $(BUILD)_opt/Frontend.native ../bin/frontend$(EXE); fi + + +test: $(Z3_BLD_ML)/z3.cmxa version + @echo "======== building SLAyer UnitTests/StandAlone/{$(TEST)} ========" + $(OCAMLBUILD) -tag debug \ + $(patsubst %.ml,UnitTests/StandAlone/%.native,$(TEST)) + @for ut in $(patsubst %.ml,%.native,$(TEST)); do \ + cp -p $(BUILD)/UnitTests/StandAlone/$$ut ../bin/$$ut; \ + done + + +testopt: $(Z3_BLD_ML)/z3.cmxa version + @echo "======== building SLAyer UnitTests/StandAlone/{$(TEST)} ========" + @$(OCAMLBUILD) \ + -build-dir $(BUILD_DIR)_opt -tag debug \ + -cflags -noassert,-unsafe -lflags -noassert,-unsafe \ + $(patsubst %.ml,UnitTests/StandAlone/%.native,$(TEST)) + @for ut in $(patsubst %.ml,%.native,$(TEST)); do \ + cp -p $(BUILD_DIR)_opt/UnitTests/StandAlone/$$ut ../bin/$$ut; \ + done + + +module: $(Z3_BLD_ML)/z3.cma version + $(OCAMLBUILD) -tag debug \ + $(M).byte + + +moduleasm: version + $(OCAMLBUILD) -tag debug \ + -cflags -noassert,-unsafe -lflags -noassert,-unsafe \ + -ocamlopt 'ocamlopt.opt -S' \ + $(M).native + + +byte: $(Z3_BLD_ML)/z3.cma version + -$(OCAMLBUILD) -tag debug \ + slayer.byte Frontend.byte + + +## Versioning + +.PHONY: +version: + echo "let version = \"$(shell git describe --tags)\"" > Version.ml + + +## Z3 +ifeq ($(OS), Windows_NT) +$(Z3_BLD)/Makefile: + @test "[ $(shell python -c 'import os; print os.name') = nt ]" \ + || (echo "Python does not report OS is Windows NT. Do not use cygwin python."; exit 1) + cd $(Z3_SRC)/..; python scripts/mk_make.py --parallel=$(NPROCS) +else +$(Z3_BLD)/Makefile: + cd $(Z3_SRC)/..; python scripts/mk_make.py +endif + +$(Z3_BLD_ML)/Makefile: $(Z3_SRC)/api/ml/Makefile.build + mkdir -p $(Z3_BLD_ML) + cp -p $(Z3_SRC)/api/ml/Makefile.build $(Z3_BLD_ML)/Makefile + +ifeq ($(OS), Windows_NT) +.PHONY: +z3dll: $(Z3_BLD)/Makefile + cd $(Z3_BLD); nmake /nologo api_dll +else +.PHONY: +z3dll: $(Z3_BLD)/Makefile + $(MAKE) -j $(NPROCS) -C $(Z3_BLD) api_dll +endif + +$(Z3_BLD_ML)/%.cma $(Z3_BLD_ML)/%.cmxa: $(Z3_BLD_ML)/Makefile z3dll + $(MAKE) DEPS='$(CURDIR)/_build*/{Slayer,CounterExample,Pure}.cm{i,o,x}' ARGS='-DUNSAFE_ERRORS -DLEAK_CONTEXTS' -C $(Z3_BLD_ML) z3.cma z3.cmxa + + +## SLAyer build tools + +get-tools: get-flexdll get-ocaml get-sdv get-esp + +get-flexdll: + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/flexdll/0.31 ../tools/flexdll ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + +get-ocaml: get-flexdll + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/ocaml/4.01.0 ../tools/ocaml ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + +get-sdv: + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/sdv ../tools/sdv ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + +get-esp: + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/esp ../tools/esp ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + pushd ../tools/esp/ocaml; cmd /c build.cmd; popd + + +## Documentation + +# files to document: module dependencies +# +# This list is manually produced from the final link command generated by +# ocamlbuild, removing Timer files, duplicating the list, and +# changing the file extensions. +# +SLAYER_DOC_MOD= \ +Library/NSLib.mli Library/NSArg.mli Library/NSOption.mli Library/NSList.mli Library/NSSet.mli Library/NSBinaryRelation.mli Library/NSHashtbl.mli Library/NSHashMap.mli Library/NSHashMultiMap.mli Library/NSPolyHashMap.mli Library/NSHashSet.mli Library/NSMap.mli Library/NSImperativeMap.mli Library/NSMultiMap.mli Library/NSImperativeMultiMap.mli Library/NSImperativeSet.mli Library/NSIndexedSet.mli Library/NSMultiSet.mli Library/NSSortedList.mli Library/NSString.mli Library/NSTuple.mli Library.mli Config.mli Hooks.mli Variable.mli Field.mli Log.mli Type.mli Expression.mli Graph_sig.mli Graph.mli Substitution.mli Pure.mli UnitTests/TestGen.mli SymbolicHeap.mli SIL.mli Interproc_sig.mli AbstractTransitionSystem.mli Discovery.mli HeapGraph.mli UnitTests/TestGenProver.mli Prover.mli Reachability.mli HeapAbstraction.mli Abstraction.mli Interproc.mli Frame.mli SymbolicExecution.mli Analysis.mli SIL_wf.mli Inline.mli Statistics.mli Initialize.mli JoinPoint.mli Peephole.mli slayer.mli \ +Library/NSLib.ml Library/NSArg.ml Library/NSOption.ml Library/NSList.ml Library/NSSet.ml Library/NSBinaryRelation.ml Library/NSHashtbl.ml Library/NSHashMap.ml Library/NSHashMultiMap.ml Library/NSPolyHashMap.ml Library/NSHashSet.ml Library/NSMap.ml Library/NSImperativeMap.ml Library/NSMultiMap.ml Library/NSImperativeMultiMap.ml Library/NSImperativeSet.ml Library/NSIndexedSet.ml Library/NSMultiSet.ml Library/NSSortedList.ml Library/NSString.ml Library/NSTuple.ml Library.ml Config.ml Hooks.ml Variable.ml Field.ml Log.ml Type.ml Expression.ml Graph_sig.ml Graph.ml Substitution.ml Pure.ml UnitTests/TestGen.ml SymbolicHeap.ml SIL.ml Interproc_sig.ml AbstractTransitionSystem.ml Discovery.ml HeapGraph.ml UnitTests/TestGenProver.ml Prover.ml Reachability.ml HeapAbstraction.ml Abstraction.ml Interproc.ml Frame.ml SymbolicExecution.ml Analysis.ml SIL_wf.ml Inline.ml Statistics.ml Initialize.ml JoinPoint.ml Peephole.ml slayer.ml + +# contaminated/PolySet.mli Library/NSPolySet.mli CounterExample.mli Instrumentation.mli ReconstructSpecs.mli Unification.mli Predicates.mli PredicateEval.mli +# contaminated/PolySet.ml Library/NSPolySet.ml CounterExample.ml Instrumentation.ml ReconstructSpecs.ml Unification.ml Predicates.ml PredicateEval.ml + +# Don't document Timer since it needs camlp4, and it isn't obvious how to tell +# ocamldoc to run camlp4 on only one file. +# Timer.mli Timer.ml + +# files to document: html docs +SLAYER_DOC= $(SLAYER_DOC_MOD) + +MISSING_MLI= Graph_sig.mli Interproc_sig.mli + +.PHONY: clean_missing_mli +clean_missing_mli: + rm -f $(MISSING_MLI:%=$(BUILD)/%) \ + $(MISSING_MLI:%=%) \ + $(MISSING_MLI:%.mli=$(BUILD)/%.cmi) \ + $(MISSING_MLI:%.mli=$(BUILD)/%.mli.depends) + +../bin: + mkdir -p ../bin + +%.mli : %.ml + ocamlc -I $(BUILD) -i $< > $*.mli + +%.pdf : %.dot + dot -Tpdf doc/$< > doc/$*.pdf + +OCAMLDOC_FLAGS= \ + -d doc \ + -I $(BUILD) \ + -I $(SRC)/../tools/Z3/src/api/ml/ \ + -I $(BUILD)/Library/ \ + -I $(BUILD)/contaminated \ + -I $(BUILD)/UnitTests + + +.PHONY: doc +doc: byte $(MISSING_MLI) + echo "\ngenerating SLAyer source documentation\n" + mkdir -p doc + ocamldoc.opt -keep-code -html -short-functors -t SLAyer \ + -hide Variable,Expression,SymbolicHeap \ + $(OCAMLDOC_FLAGS) doc/depend_module.mli $(SLAYER_DOC) + rm -f ocamldoc.out + $(MAKE) clean_missing_mli + +# @echo "\ngenerating SLAyer module dependency graph\n" +# ocamldoc.opt -dot -dot-reduce \ +# $(OCAMLDOC_FLAGS) $(SLAYER_DOC_MOD) +# dot -Tpdf ocamldoc.out > doc/depend_module.pdf + +.PHONY: depend_module +depend_module: depend_module.dot +depend_module.dot: default $(MISSING_MLI) + @echo "\ngenerating SLAyer module dependency graph\n" + OCAMLLIB=$(SRC)/../tools/ocaml/lib \ + ocamldoc.opt -dot -dot-reduce \ + $(OCAMLDOC_FLAGS) $(SLAYER_DOC_MOD) + mv ocamldoc.out doc/depend_module.dot + $(MAKE) clean_missing_mli + +.PHONY: depend_module_full +depend_module_full: depend_module_full.dot +depend_module_full.dot: default $(MISSING_MLI) + @echo "\ngenerating SLAyer unreduced module dependency graph\n" + OCAMLLIB=$(SRC)/../tools/ocaml/lib \ + ocamldoc.opt -dot \ + $(OCAMLDOC_FLAGS) $(SLAYER_DOC_MOD) + mv ocamldoc.out doc/depend_module_full.dot + $(MAKE) clean_missing_mli + +.PHONY: depend_type +depend_type: depend_type.dot +depend_type.dot: default $(MISSING_MLI) + @echo "\ngenerating SLAyer type dependency graph\n" + OCAMLLIB=$(SRC)/../tools/ocaml/lib \ + ocamldoc.opt -dot-types $(OCAMLDOC_FLAGS) $(SLAYER_DOC) + mv ocamldoc.out doc/depend_type.dot + $(MAKE) clean_missing_mli + + +# cleanup +clean_slayer: clean_missing_mli + rm -f Version.ml _build*/*.{ml,mli,cmi,cmo,cmx,cma,cmxa,o,obj,depends} + +clean: clean_slayer + rm -rf _build* *~ */*~ ../bin/slayer$(EXE) ../bin/frontend$(EXE) ../bin/*.byte ../bin/*.native doc/*.html doc/depend_module.pdf + +clean_mlz3: + $(MAKE) -C $(Z3_BLD_ML) clean + +clean_z3: + rm -rf $(Z3_BLD) diff --git a/src/Makefile.txt b/src/Makefile.txt new file mode 100644 index 0000000..2fb7f24 --- /dev/null +++ b/src/Makefile.txt @@ -0,0 +1,305 @@ +# Copyright (c) Microsoft Corporation. All rights reserved. + +# Detect operating system, architecture, and number of processors +ifeq (${OS},Windows_NT) + ARCH=x86 + NPROCS:=$(subst NumberOfLogicalProcessors=,,$(strip $(shell wmic cpu get NumberOfLogicalProcessors /value))) +else + OS := $(shell uname -s) + ARCH := $(shell uname -m) +ifeq ($(OS), Linux) + NPROCS:=$(shell nproc) +endif +ifeq ($(OS), Darwin) + NPROCS:=$(subst hw.ncpu: ,,$(shell sysctl hw.ncpu)) +endif +endif + +ifeq ($(OS), Windows_NT) +# path to the root of the SLAyer source, in windows format since it is passed to the linker +SRC=$(shell cygpath -m $(CURDIR)) +EXE=.exe +OSBUILDFLAGS=-lib esp -lflags "-cclib /link/NODEFAULTLIB:LIBCMT" +Frontend_byte=Frontend.byte +Frontend_native=Frontend.native +else +SRC=$(CURDIR) +endif + + +# To build SLAyer execute: +# make +# To build all unit tests execute: +# make test +# To build a set of unit tests ... execute: +# make TEST={.ml ... .ml} test +# +# By default set TEST to the set of ml files in StandAlone: +TEST:=$(notdir $(wildcard $(SRC)/UnitTests/StandAlone/*.ml)) + +# To build a single module execute: +# make M= module +M= + +SLAyer_CFLAGS?=-cflags -annot + +# Note: ocamlbuild seems not to have a rule for building .cmi, .cmx, and .o +# from .ml directly, and instead builds .cmo and .cmi from .ml and then +# builds .cmx and .o from .cmi and .ml, thereby compiling everything twice. + + +# path to the Z3 source directory, build directory, and the subdirectory for the compiled OCaml interface +# these are in unix format since they are used in make rules where windows' colons are invalid +Z3_SRC=$(CURDIR)/../tools/Z3/src +Z3_BLD=$(Z3_SRC)/../build +Z3_BLD_ML=$(Z3_BLD)/api/ml +# and in windows format for the linker +Z3_BLD_ML_WIN=$(SRC)/../tools/Z3/build/api/ml + +# path to the ESP compiled OCaml interface, in windows format for the linker +ESP_BLD=$(SRC)/../tools/esp/ocaml + +# name of directory to contain SLAyer compiled code +BUILD=_build/$(OS)/$(ARCH) + +# common ocamlbuild options +OCAMLBUILD= \ + ocamlbuild \ + -j $(NPROCS) -no-links -build-dir $(BUILD) \ + -tag bin_annot \ + -cflags "-short-paths -w +6+7+27+29+32..39+41+44+45" \ + -cflags -I,$(ESP_BLD) -lflags -I,$(ESP_BLD) \ + -cflags -I,$(Z3_BLD_ML_WIN) -lflags -I,$(Z3_BLD_ML_WIN) \ + $(SLAyer_CFLAGS) \ + -Is Library,contaminated,UnitTests,UnitTests/StandAlone \ + -libs str,unix,z3 \ + $(OSBUILDFLAGS) + + +## SLAyer targets + +default: dbg + +help: + @cat README + +all: dbg opt #doc + + +dbg: $(Z3_BLD_ML)/z3.cma $(Z3_BLD_ML)/z3.cmxa ../bin version + @echo "======== building SLAyer debug (byte & native) code ========" + $(OCAMLBUILD) -tag debug \ + slayer.byte $(Frontend_byte) slayer.native $(Frontend_native) + -@cp -p $(BUILD)/slayer.native ../bin/slayer$(EXE) + -@if test -f $(BUILD)/Frontend.native; then cp -p $(BUILD)/Frontend.native ../bin/frontend$(EXE); fi + + +opt: $(Z3_BLD_ML)/z3.cmxa ../bin version + @echo "======== building SLAyer optimized (native) code ========" + $(OCAMLBUILD) -build-dir $(BUILD)_opt -tag debug -cflags -noassert,-unsafe -lflags -noassert,-unsafe \ + slayer.native $(Frontend_native) + -@cp -p $(BUILD)_opt/slayer.native ../bin/slayer$(EXE) + -@if test -f $(BUILD)_opt/Frontend.native; then cp -p $(BUILD)_opt/Frontend.native ../bin/frontend$(EXE); fi + + +test: $(Z3_BLD_ML)/z3.cmxa version + @echo "======== building SLAyer UnitTests/StandAlone/{$(TEST)} ========" + $(OCAMLBUILD) -tag debug \ + $(patsubst %.ml,UnitTests/StandAlone/%.native,$(TEST)) + @for ut in $(patsubst %.ml,%.native,$(TEST)); do \ + cp -p $(BUILD)/UnitTests/StandAlone/$$ut ../bin/$$ut; \ + done + + +testopt: $(Z3_BLD_ML)/z3.cmxa version + @echo "======== building SLAyer UnitTests/StandAlone/{$(TEST)} ========" + @$(OCAMLBUILD) \ + -build-dir $(BUILD_DIR)_opt -tag debug \ + -cflags -noassert,-unsafe -lflags -noassert,-unsafe \ + $(patsubst %.ml,UnitTests/StandAlone/%.native,$(TEST)) + @for ut in $(patsubst %.ml,%.native,$(TEST)); do \ + cp -p $(BUILD_DIR)_opt/UnitTests/StandAlone/$$ut ../bin/$$ut; \ + done + + +module: $(Z3_BLD_ML)/z3.cma version + $(OCAMLBUILD) -tag debug \ + $(M).byte + + +moduleasm: version + $(OCAMLBUILD) -tag debug \ + -cflags -noassert,-unsafe -lflags -noassert,-unsafe \ + -ocamlopt 'ocamlopt.opt -S' \ + $(M).native + + +byte: $(Z3_BLD_ML)/z3.cma version + -$(OCAMLBUILD) -tag debug \ + slayer.byte Frontend.byte + + +## Versioning + +.PHONY: +version: + echo "let version = \"$(shell git describe --tags)\"" > Version.ml + + +## Z3 +ifeq ($(OS), Windows_NT) +$(Z3_BLD)/Makefile: + @test "[ $(shell python -c 'import os; print os.name') = nt ]" \ + || (echo "Python does not report OS is Windows NT. Do not use cygwin python."; exit 1) + cd $(Z3_SRC)/..; python scripts/mk_make.py --parallel=$(NPROCS) +else +$(Z3_BLD)/Makefile: + cd $(Z3_SRC)/..; python scripts/mk_make.py +endif + +$(Z3_BLD_ML)/Makefile: $(Z3_SRC)/api/ml/Makefile.build + mkdir -p $(Z3_BLD_ML) + cp -p $(Z3_SRC)/api/ml/Makefile.build $(Z3_BLD_ML)/Makefile + +ifeq ($(OS), Windows_NT) +.PHONY: +z3dll: $(Z3_BLD)/Makefile + cd $(Z3_BLD); nmake /nologo api_dll +else +.PHONY: +z3dll: $(Z3_BLD)/Makefile + $(MAKE) -j $(NPROCS) -C $(Z3_BLD) api_dll +endif + +$(Z3_BLD_ML)/%.cma $(Z3_BLD_ML)/%.cmxa: $(Z3_BLD_ML)/Makefile z3dll + $(MAKE) DEPS='$(CURDIR)/_build*/{Slayer,CounterExample,Pure}.cm{i,o,x}' ARGS='-DUNSAFE_ERRORS -DLEAK_CONTEXTS' -C $(Z3_BLD_ML) z3.cma z3.cmxa + + +## SLAyer build tools + +get-tools: get-flexdll get-ocaml get-sdv get-esp + +get-flexdll: + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/flexdll/0.31 ../tools/flexdll ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + +get-ocaml: get-flexdll + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/ocaml/4.01.0 ../tools/ocaml ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + +get-sdv: + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/sdv ../tools/sdv ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + +get-esp: + robocopy /mir //cam-01-srv/dfsroot/groups/varg/tools/esp ../tools/esp ; \ + if [ $$? -ge 8 ]; then $$? else 0; fi + pushd ../tools/esp/ocaml; cmd /c build.cmd; popd + + +## Documentation + +# files to document: module dependencies +# +# This list is manually produced from the final link command generated by +# ocamlbuild, removing Timer files, duplicating the list, and +# changing the file extensions. +# +SLAYER_DOC_MOD= \ +Library/NSLib.mli Library/NSArg.mli Library/NSOption.mli Library/NSList.mli Library/NSSet.mli Library/NSBinaryRelation.mli Library/NSHashtbl.mli Library/NSHashMap.mli Library/NSHashMultiMap.mli Library/NSPolyHashMap.mli Library/NSHashSet.mli Library/NSMap.mli Library/NSImperativeMap.mli Library/NSMultiMap.mli Library/NSImperativeMultiMap.mli Library/NSImperativeSet.mli Library/NSIndexedSet.mli Library/NSMultiSet.mli Library/NSSortedList.mli Library/NSString.mli Library/NSTuple.mli Library.mli Config.mli Hooks.mli Variable.mli Field.mli Log.mli Type.mli Expression.mli Graph_sig.mli Graph.mli Substitution.mli Pure.mli UnitTests/TestGen.mli SymbolicHeap.mli SIL.mli Interproc_sig.mli AbstractTransitionSystem.mli Discovery.mli HeapGraph.mli UnitTests/TestGenProver.mli Prover.mli Reachability.mli HeapAbstraction.mli Abstraction.mli Interproc.mli Frame.mli SymbolicExecution.mli Analysis.mli SIL_wf.mli Inline.mli Statistics.mli Initialize.mli JoinPoint.mli Peephole.mli slayer.mli \ +Library/NSLib.ml Library/NSArg.ml Library/NSOption.ml Library/NSList.ml Library/NSSet.ml Library/NSBinaryRelation.ml Library/NSHashtbl.ml Library/NSHashMap.ml Library/NSHashMultiMap.ml Library/NSPolyHashMap.ml Library/NSHashSet.ml Library/NSMap.ml Library/NSImperativeMap.ml Library/NSMultiMap.ml Library/NSImperativeMultiMap.ml Library/NSImperativeSet.ml Library/NSIndexedSet.ml Library/NSMultiSet.ml Library/NSSortedList.ml Library/NSString.ml Library/NSTuple.ml Library.ml Config.ml Hooks.ml Variable.ml Field.ml Log.ml Type.ml Expression.ml Graph_sig.ml Graph.ml Substitution.ml Pure.ml UnitTests/TestGen.ml SymbolicHeap.ml SIL.ml Interproc_sig.ml AbstractTransitionSystem.ml Discovery.ml HeapGraph.ml UnitTests/TestGenProver.ml Prover.ml Reachability.ml HeapAbstraction.ml Abstraction.ml Interproc.ml Frame.ml SymbolicExecution.ml Analysis.ml SIL_wf.ml Inline.ml Statistics.ml Initialize.ml JoinPoint.ml Peephole.ml slayer.ml + +# contaminated/PolySet.mli Library/NSPolySet.mli CounterExample.mli Instrumentation.mli ReconstructSpecs.mli Unification.mli Predicates.mli PredicateEval.mli +# contaminated/PolySet.ml Library/NSPolySet.ml CounterExample.ml Instrumentation.ml ReconstructSpecs.ml Unification.ml Predicates.ml PredicateEval.ml + +# Don't document Timer since it needs camlp4, and it isn't obvious how to tell +# ocamldoc to run camlp4 on only one file. +# Timer.mli Timer.ml + +# files to document: html docs +SLAYER_DOC= $(SLAYER_DOC_MOD) + +MISSING_MLI= Graph_sig.mli Interproc_sig.mli + +.PHONY: clean_missing_mli +clean_missing_mli: + rm -f $(MISSING_MLI:%=$(BUILD)/%) \ + $(MISSING_MLI:%=%) \ + $(MISSING_MLI:%.mli=$(BUILD)/%.cmi) \ + $(MISSING_MLI:%.mli=$(BUILD)/%.mli.depends) + +../bin: + mkdir -p ../bin + +%.mli : %.ml + ocamlc -I $(BUILD) -i $< > $*.mli + +%.pdf : %.dot + dot -Tpdf doc/$< > doc/$*.pdf + +OCAMLDOC_FLAGS= \ + -d doc \ + -I $(BUILD) \ + -I $(SRC)/../tools/Z3/src/api/ml/ \ + -I $(BUILD)/Library/ \ + -I $(BUILD)/contaminated \ + -I $(BUILD)/UnitTests + + +.PHONY: doc +doc: byte $(MISSING_MLI) + echo "\ngenerating SLAyer source documentation\n" + mkdir -p doc + ocamldoc.opt -keep-code -html -short-functors -t SLAyer \ + -hide Variable,Expression,SymbolicHeap \ + $(OCAMLDOC_FLAGS) doc/depend_module.mli $(SLAYER_DOC) + rm -f ocamldoc.out + $(MAKE) clean_missing_mli + +# @echo "\ngenerating SLAyer module dependency graph\n" +# ocamldoc.opt -dot -dot-reduce \ +# $(OCAMLDOC_FLAGS) $(SLAYER_DOC_MOD) +# dot -Tpdf ocamldoc.out > doc/depend_module.pdf + +.PHONY: depend_module +depend_module: depend_module.dot +depend_module.dot: default $(MISSING_MLI) + @echo "\ngenerating SLAyer module dependency graph\n" + OCAMLLIB=$(SRC)/../tools/ocaml/lib \ + ocamldoc.opt -dot -dot-reduce \ + $(OCAMLDOC_FLAGS) $(SLAYER_DOC_MOD) + mv ocamldoc.out doc/depend_module.dot + $(MAKE) clean_missing_mli + +.PHONY: depend_module_full +depend_module_full: depend_module_full.dot +depend_module_full.dot: default $(MISSING_MLI) + @echo "\ngenerating SLAyer unreduced module dependency graph\n" + OCAMLLIB=$(SRC)/../tools/ocaml/lib \ + ocamldoc.opt -dot \ + $(OCAMLDOC_FLAGS) $(SLAYER_DOC_MOD) + mv ocamldoc.out doc/depend_module_full.dot + $(MAKE) clean_missing_mli + +.PHONY: depend_type +depend_type: depend_type.dot +depend_type.dot: default $(MISSING_MLI) + @echo "\ngenerating SLAyer type dependency graph\n" + OCAMLLIB=$(SRC)/../tools/ocaml/lib \ + ocamldoc.opt -dot-types $(OCAMLDOC_FLAGS) $(SLAYER_DOC) + mv ocamldoc.out doc/depend_type.dot + $(MAKE) clean_missing_mli + + +# cleanup +clean_slayer: clean_missing_mli + rm -f Version.ml _build*/*.{ml,mli,cmi,cmo,cmx,cma,cmxa,o,obj,depends} + +clean: clean_slayer + rm -rf _build* *~ */*~ ../bin/slayer$(EXE) ../bin/frontend$(EXE) ../bin/*.byte ../bin/*.native doc/*.html doc/depend_module.pdf + +clean_mlz3: + $(MAKE) -C $(Z3_BLD_ML) clean + +clean_z3: + rm -rf $(Z3_BLD) diff --git a/src/Program.ml b/src/Program.ml new file mode 100644 index 0000000..7077580 --- /dev/null +++ b/src/Program.ml @@ -0,0 +1,741 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Internal representation of programs *) + +open Library + +open Type +open Variable +open Expression +module E = Exp +module S = Substitution +module HC = HashCons +open SymbolicHeap + +module L = (val Log.std Config.vPgm : Log.LOG) + +let unmarshal_tmr = Timer.create "Program.unmarshal" + + + +(*============================================================================ + Source Code Positions + ============================================================================*) + +module Position = struct + + type t = { dir : string; file : string; line : int; col : int; } + + let compare = Pervasives.compare + let equal = Pervasives.( = ) + + let fmt ff {line; file} = Format.fprintf ff "line %i %s" line file + +end + + + +(*============================================================================ + Instructions + ============================================================================*) + +(** Instructions. The machine model is ideal RISC: an infinite number of + word-sized registers (the Var.t's), memory only accessed via + load/stores. *) +module Inst = struct + + type desc = + | Load of Var.t * Exp.t + | Store of Exp.t * Exp.t + | Alloc of Var.t * Exp.t + | Free of Exp.t + | Kill of Vars.t + | Move of Var.t * Exp.t + | Cast of Var.t * Typ.t * Exp.t + | Assume of Exp.t + | Assert of Exp.t + | Nop + | Generic of spec + + (** Specifications, whose meaning is the Hoare triple [forall ghosts. {pre} insts {post}]. *) + and spec = { ghosts : Vars.t; pre : XSH.t; insts : desc list; post : XSH.t; } + + + type t = { desc : desc; pos : Position.t; } + + + let compare_desc c0 c1 = match c0, c1 with + | Load(x0,e0) , Load(x1,e1) -> + compare_tup2 Var.compare Exp.compare (x0,e0) (x1,e1) + | Load(_) , _ -> -1 + | _ , Load(_) -> 1 + | Store(e0,f0), Store(e1,f1) -> + compare_tup2 Exp.compare Exp.compare (e0,f0) (e1,f1) + | Store(_) , _ -> -1 + | _ , Store(_) -> 1 + | Alloc(x0,e0), Alloc(x1,e1) -> + let o = Var.compare x0 x1 in if o <> 0 then o else Exp.compare e0 e1 + | Alloc(_) , _ -> -1 + | _ , Alloc(_) -> 1 + | Free(e0) , Free(e1) -> Exp.compare e0 e1 + | Free(_) , _ -> -1 + | _ , Free(_) -> 1 + | Kill(x0) , Kill(x1) -> Vars.compare x0 x1 + | Kill(_) , _ -> -1 + | _ , Kill(_) -> 1 + | Move(x0,e0) , Move(x1,e1) -> + compare_tup2 Var.compare Exp.compare (x0,e0) (x1,e1) + | Move(_) , _ -> -1 + | _ , Move(_) -> 1 + | Cast(v0,t0,e0) , Cast(v1,t1,e1) -> + compare_tup3 Var.compare Typ.compare Exp.compare (v0,t0,e0) (v1,t1,e1) + | Cast(_) , _ -> -1 + | _ , Cast(_) -> 1 + | Assume(e0) , Assume(e1) -> Exp.compare e0 e1 + | Assume(_) , _ -> -1 + | _ , Assume(_) -> 1 + | Assert(e0) , Assert(e1) -> Exp.compare e0 e1 + | Assert(_) , _ -> -1 + | _ , Assert(_) -> 1 + | Nop , Nop -> 0 + | Nop , _ -> -1 + | _ , Nop -> 1 + | Generic({ghosts=g0; pre=p0; insts=cc0; post=q0}), Generic({ghosts=g1; pre=p1; insts=cc1; post=q1}) -> + compare_tup4 Vars.compare XSH.compare (List.compare compare) XSH.compare (g0, p0, cc0, q0) (g1, p1, cc1, q1) + + let compare c0 c1 = compare_desc c0.desc c1.desc + + + let rec equal_desc c0 c1 = + match c0, c1 with + | Load(x0,e0) , Load(x1,e1) -> + equal_tup2 Var.equal Exp.equal (x0,e0) (x1,e1) + | Store(e0,f0), Store(e1,f1) -> + equal_tup2 Exp.equal Exp.equal (e0,f0) (e1,f1) + | Alloc(x0,e0), Alloc(x1,e1) -> Var.equal x0 x1 && Exp.equal e0 e1 + | Free(e0) , Free(e1) -> Exp.equal e0 e1 + | Kill(x0) , Kill(x1) -> Vars.equal x0 x1 + | Move(x0,e0) , Move(x1,e1) -> + equal_tup2 Var.equal Exp.equal (x0,e0) (x1,e1) + | Cast(v0,t0,e0) , Cast(v1,t1,e1) -> + equal_tup3 Var.equal Typ.equal Exp.equal (v0,t0,e0) (v1,t1,e1) + | Assume(e0) , Assume(e1) -> Exp.equal e0 e1 + | Assert(e0) , Assert(e1) -> Exp.equal e0 e1 + | Generic({ghosts=g0; pre=p0; insts=cc0; post=q0}), Generic({ghosts=g1; pre=p1; insts=cc1; post=q1}) -> + equal_tup4 Vars.equal XSH.equal (List.equal equal_desc) XSH.equal (g0, p0, cc0, q0) (g1, p1, cc1, q1) + | _ -> false + + let equal c0 c1 = equal_desc c0.desc c1.desc + + + (** free variables *) + let rec fv_desc = function + | Kill(xs) -> xs + | Move(x,e) + | Cast(x,_,e) + | Load(x,e) + | Alloc(x,e) -> Vars.add x (Exp.fv e) + | Store(e,f) -> Vars.union (Exp.fv e) (Exp.fv f) + | Free(e) + | Assert(e) + | Assume(e) -> Exp.fv e + | Nop -> Vars.empty + | Generic({ghosts; pre; insts; post}) -> + List.fold (fun c -> Vars.union (fv_desc c)) insts + (Vars.diff (Vars.union (XSH.fv pre) (XSH.fv post)) ghosts) + + let fv inst = fv_desc inst.desc + + + let rec mv_desc = function + | Move(x,_) + | Cast(x,_,_) + | Load(x,_) + | Alloc(x,_) -> Vars.singleton x + | Free _ + | Assert _ + | Assume _ + | Nop + | Store _ -> Vars.empty + | Kill(vs) -> vs + | Generic({insts}) -> List.fold (fun c ms -> Vars.union (mv_desc c) ms) insts Vars.empty + + let mv inst = mv_desc inst.desc + + + let rec fmt_desc ff = function + | Load(x,l) -> Format.fprintf ff "@[load(@[%a,@ %a@])@]" Var.fmt x Exp.fmt l + | Store(l,r) -> Format.fprintf ff "@[store(@[%a,@ %a@])@]" Exp.fmt l Exp.fmt r + | Alloc(x,e) -> Format.fprintf ff "@[alloc(@[%a,@ %a@])@]" Var.fmt x Exp.fmt e + | Free(e) -> Format.fprintf ff "@[free(@[%a@])@]" Exp.fmt e + | Kill(vs) -> Format.fprintf ff "@[kill(@[%a@])@]" Vars.fmt vs + | Move(x,l) -> Format.fprintf ff "@[move(@[%a,@ %a@])@]" Var.fmt x Exp.fmt l + | Cast(v,t,e) -> + let vl = !Config.vTyp in Config.vTyp := max 1 vl; + Format.fprintf ff "@[cast(@[%a,@ %a,@ %a@])@]" Var.fmt v Typ.fmt t Exp.fmt e ; + Config.vTyp := vl + | Assume(e) -> Format.fprintf ff "@[assume(@[%a@])@]" Exp.fmt e + | Assert(e) -> Format.fprintf ff "@[assert(@[%a@])@]" Exp.fmt e + | Nop -> Format.fprintf ff "nop" + | Generic(s) -> + Format.fprintf ff "@[generic%a%a@ %a%a@]" + (Vars.fmt_embrace " ! " " .@ ") s.ghosts + XSH.fmt s.pre + (List.fmt ";@ " fmt_desc) s.insts + XSH.fmt s.post + + let fmt_desc_c ff = function + | Load(x,l) -> Format.fprintf ff "@[%a = *%a@]" Var.fmt x Exp.fmt l + | Store(l,r) -> Format.fprintf ff "@[*%a = %a@]" Exp.fmt l Exp.fmt r + | Alloc(x,e) -> Format.fprintf ff "@[%a = malloc(%a)@]" Var.fmt x Exp.fmt e + | Free(e) -> Format.fprintf ff "@[free(@[%a@])@]" Exp.fmt e + | Kill(vs) -> Format.fprintf ff "%a = nondet()" (List.fmt " = nondet();@ " Var.fmt) (Vars.to_list vs) + | Move(x,l) -> Format.fprintf ff "@[%a = %a@]" Var.fmt x Exp.fmt l + | Cast(v,t,e) -> + let vl = !Config.vTyp in Config.vTyp := max 1 vl; + Format.fprintf ff "@[%a = %a%a@]" Var.fmt v Typ.fmt t Exp.fmt e ; + Config.vTyp := vl + | Assume(e) -> Format.fprintf ff "@[assume(@[%a@])@]" Exp.fmt e + | Assert(e) -> Format.fprintf ff "@[assert(@[%a@])@]" Exp.fmt e + | Nop -> Format.fprintf ff ";" + | Generic _ as i -> fmt_desc ff i + + let fmt ff k = if !Config.c_syntax then fmt_desc_c ff k.desc else fmt_desc ff k.desc + + + let report_ill_sorted c = + (if Config.check_sorts then failwithf else L.warnf) "ill-sorted: %a" fmt_desc c + + let mk desc pos = + (fun {desc} -> assert( + (match desc with + | Alloc(x,e) -> Var.sort x = Var.PointerSort && Exp.sort_of e = Var.IntegerSort + | Free(e) + | Load(_,e) + | Store(e,_) -> Exp.sort_of e = Var.PointerSort + | Move(x,e) -> Var.sort x = Exp.sort_of e + | Cast(x,t,_) -> Var.sort x = Var.sort_of_type t + | Assert(e) + | Assume(e) -> Exp.sort_of e = Var.BooleanSort + | Kill _ + | Nop + | Generic _ -> true + ) || report_ill_sorted desc + )) <& + let desc = + match desc with + | Kill(vs) when Vars.is_empty vs -> + Nop + | Move(x,e) -> + (match E.convert (Var.sort x) e with + | Some(f) -> Move(x,f) + | None -> desc + ) + | Cast(x,t,l) -> + (match Exp.convert (Var.sort x) l with + | None -> + Kill(Vars.singleton x) + | Some(l) -> + match Typ.desc t with + | Typ.Pointer(ty) when Typ.equal Typ.mkTop ty -> + Move(x,l) + | _ -> + desc + ) + | _ -> + desc + in + {desc; pos} + +end +module I = Inst + + +(*============================================================================ + Procedure Identifiers + ============================================================================*) + +module ProcId = struct + + type t = int * string + + include UniqueId.Make (struct + type data = string + type uniq = t + let get (x,_) = x + let set x s = (x, s) + end) + + let name (_,s) = s + + let fmt ff (i,s) = + if !Config.vPgm > 1 then + Format.fprintf ff "%s_%i" s i + else + Format.fprintf ff "%s" s + +end + + +(*============================================================================ + Control-Flow Point Labels + ============================================================================*) + +module ControlPointLabel = struct + + module Id = struct + + type t = int + + include UniqueId.Make (struct + type data = unit + type uniq = t + let get x = x + let set x () = x + end) + + let fmt ff i = Format.fprintf ff "k %i" i + + end + + type sort = Entry | Exit | Return | Cut | Join | Fork + + type label = { id : Id.t; sort : sort option; pos : Position.t; proc : ProcId.t; } + + let mk_label ?sort pos proc = + let id = Id.gensym () in + (id, {id; sort; pos; proc}) + + let set_sort l sort = + {l with sort} + + let compare x y = Id.compare x.id y.id + let equal x y = Id.equal x.id y.id + + + let fmt_sort ff = function + | Entry -> Format.fprintf ff "Entry" + | Exit -> Format.fprintf ff "Exit" + | Return -> Format.fprintf ff "Return" + | Cut -> Format.fprintf ff "Cut" + | Join -> Format.fprintf ff "Join" + | Fork -> Format.fprintf ff "Fork" + + let fmt ff k = + Format.fprintf ff "%a: %a" Position.fmt k.pos (Option.fmt "" fmt_sort) k.sort + +end + + +(*============================================================================ + Procedure Calls + ============================================================================*) + +module Call0 = struct + + type 'a t = { + proc : 'a; + actuals : Var.t list; + areturn : Var.t option; + typ : Typ.t; + targets : ProcId.t list; + } + + let fv {actuals; areturn} = Option.fold Vars.add areturn (Vars.of_list actuals) + + let mv {areturn} = Option.fold Vars.add areturn Vars.empty + + let compare compare_proc x y = + let {proc= proc0; actuals= actuals0; areturn= areturn0} = x in + let {proc= proc1; actuals= actuals1; areturn= areturn1} = y in + let c = compare_proc proc0 proc1 in if c <> 0 then c else + let c = List.compare Var.compare actuals0 actuals1 in if c <> 0 then c else + Option.compare Var.compare areturn0 areturn1 + + let equal equal_proc x y = + let {proc= proc0; actuals= actuals0; areturn= areturn0} = x in + let {proc= proc1; actuals= actuals1; areturn= areturn1} = y in + equal_proc proc0 proc1 + && List.equal Var.equal actuals0 actuals1 + && Option.equal Var.equal areturn0 areturn1 + + let fmt fmt_proc ff {proc; actuals; areturn} = + let fmt_ret ff rv = Option.fmt "" (fun ff v -> Format.fprintf ff "%a =@ " Var.fmt v) ff rv in + let fmt_vs ff vs = List.fmt ",@ " Var.fmt ff vs in + Format.fprintf ff "@[%a@,@[%a(@[%a@])@]@]" fmt_ret areturn fmt_proc proc fmt_vs actuals + +end + + +(*============================================================================ + Commands + ============================================================================*) + +module Cmnd = struct + + type t = + | Inst of Inst.t + | Call of ProcId.t Call0.t + | ICall of Exp.t Call0.t + + let append x y = + let open I in + match x, y with + | x, Inst({desc= Nop}) -> Some(x) + | Inst({desc= Nop}), y -> Some(y) + | Inst({desc= Kill xs; pos}), Inst({desc= Kill ys}) -> Some(Inst(I.mk (Kill (Vars.union xs ys)) pos)) + | _ -> None + + let fv = function + | Inst(i) -> I.fv i + | Call(call) -> Call0.fv call + | ICall({Call0.proc} as call) -> Vars.union (Exp.fv proc) (Call0.fv call) + + let mv = function + | Inst(i) -> I.mv i + | Call(call) -> Call0.mv call + | ICall(call) -> Call0.mv call + + let compare e0 e1 = + match e0, e1 with + | Inst(x) , Inst(y) -> I.compare x y + | Inst _ , _ -> -1 + | _ , Inst _ -> 1 + | Call(x) , Call(y) -> Call0.compare ProcId.compare x y + | Call _ , _ -> -1 + | _ , Call _ -> 1 + | ICall(x) , ICall(y) -> Call0.compare Exp.compare x y + + let equal x y = compare x y = 0 + + let fmt ff t = + match t with + | Inst(i) -> I.fmt ff i + | Call(call) -> Call0.fmt ProcId.fmt ff call + | ICall(call) -> Call0.fmt Exp.fmt ff call + +end +module C = Cmnd + + +(*============================================================================ + Control-Flow Graphs + ============================================================================*) + +module CFG = struct + include Graph.Make + (ControlPointLabel.Id) + (struct include ControlPointLabel type t = label end) + (Cmnd) + + let rec add_block_edge g u blk w = + match blk with + | inst :: (_::_ as blk) -> + let v = add_vertex g (ControlPointLabel.mk_label inst.I.pos ((label_of w).ControlPointLabel.proc)) in + add_edge g u (C.Inst(inst)) v ; + add_block_edge g v blk w + | [inst] -> + add_edge g u (C.Inst(inst)) w + | [] -> + add_edge g u (C.Inst(I.mk I.Nop ((label_of u).ControlPointLabel.pos))) w + +end + + +(*============================================================================ + Control-Flow Points + ============================================================================*) + +module ControlPoint = struct + include ControlPointLabel + include CFG.Vertex + + let id cp = CFG.index_of cp + let sort cp = (CFG.label_of cp).sort + let pos cp = (CFG.label_of cp).pos + let proc cp = (CFG.label_of cp).proc + +end +module K = ControlPoint + + +(*============================================================================ + Procedures + ============================================================================*) + +module Proc = struct + + module Id = ProcId + module IdHMap = HashMap.Make(Id) + + type t = { + id : Id.t; + fty : Typ.t; + formals : Var.t list; + freturn : Var.t option; + locals : Vars.t; + modifs : Vars.t; + accessed : Vars.t; + cfg : CFG.graph; + entry : K.t; + exit : K.t; + } + + let fv p = + CFG.fold_edges + (fun _ vs -> vs) + (fun (_, e, _) vs -> Vars.union (C.fv e) vs) + p.cfg + (K.id p.entry) + Vars.empty + + let fmt ff {id; formals; freturn; locals; modifs; accessed} = + Format.fprintf ff "@[%a@ locals: {@[%a@]}@ modifs: {@[%a@]}@ access: {@[%a@]}@]" + C.fmt (C.Call{Call0.proc= id; actuals= formals; areturn= freturn; typ= Typ.mkTop; targets= []}) + Vars.fmt locals Vars.fmt modifs Vars.fmt accessed + + let compare x y = Id.compare x.id y.id + let equal x y = Id.equal x.id y.id + let hash x = Id.hash x.id + +end + + +(*============================================================================ + Procedure Calls + ============================================================================*) + +module Call = struct + include Call0 + + let mk ({Proc.id; fty} as proc) actuals areturn = + {proc; actuals; areturn; typ= fty; targets= [id]} + + let args {proc= {Proc.id; formals; freturn}; actuals; areturn} = + let rec loop frmls_to_actls rev_actls = function + | frml::frmls, actl::actls -> + loop (S.add (Exp.mkVar frml) (Exp.mkVar actl) frmls_to_actls) (actl :: rev_actls) (frmls, actls) + | [], [] -> + (frmls_to_actls, List.rev rev_actls) + | [], actls -> + L.printf 1 "ignoring extra actual parameters to @[%s(...,%a)@]" + (Proc.Id.name id) (List.fmt ",@ " Var.fmt) actls ; + (frmls_to_actls, List.rev rev_actls) + | _::_, [] -> + failwithf "exec_proc: too few arguments passed to %a" Proc.Id.fmt id + in + let formals, actuals = + match freturn, areturn with + | Some(freturn), Some(areturn) -> (freturn :: formals, areturn :: actuals) + | _ -> (formals, actuals) in + loop S.empty [] (formals, actuals) +end + + +(*============================================================================ + Programs + ============================================================================*) + +module Prog = struct + + type t = { + globals : Vars.t; + main : Proc.Id.t; + procs : Proc.t Proc.IdHMap.t; + global_setup : Proc.Id.t list; + inits : Proc.Id.t list; + addr_taken : Proc.Id.t list; + constants : int64 list; + } + + module CPHMap = HashMap.Make(K) + module ProcHMap = HashMap.Make(Proc) + + + let iter_procs fn prog = + Proc.IdHMap.iter fn prog.procs + + let map_procs fn prog = + {prog with procs= Proc.IdHMap.map fn prog.procs} + + let fold_procs fn prog z = + Proc.IdHMap.fold (fun _ p z -> fn p z) prog.procs z + + + (** fold inter ff cf fk ck x folds over x and applies ff to every proc, cf to every recursively called proc, + fk to every control point, and ck to every backward jump destination control point. If [inter] is set, + also folds over called procedures. *) + let fold_proc, fold_cp = + let closure procso ff cf fk ck = + let p_memo = ProcHMap.create 31 + in + let rec fold_p p a = + match ProcHMap.tryfind p_memo p with + | Some(true) -> + a + | Some(false) -> + ProcHMap.add p_memo p true ; + cf p a + | None -> + ProcHMap.add p_memo p false ; + fold_k p p.Proc.entry (ff p a) + and fold_k p k = + let cp_memo = CPHMap.create 31 + in + let rec loop k a = + match CPHMap.tryfind cp_memo k with + | Some(true) -> + a + | Some(false) -> + CPHMap.add cp_memo k true ; + ck p k a + | None -> + CPHMap.add cp_memo k false ; + let a = fk p k a in + List.fold (fun (succ,edge) acc -> + match edge with + | C.Inst _ -> + loop succ acc + | C.Call{Call.proc} -> + Option.fold (fun procs acc -> loop succ (fold_p (Proc.IdHMap.find procs proc) acc)) procso acc + | C.ICall _ -> + acc (* Don't approx fptrs *) + ) (CFG.successors k) a + in + loop k + in + fold_p, fold_k + in + ( (fun procs ff cf fk ck -> fst (closure procs ff cf fk ck)) + , (fun procs ff cf fk ck -> snd (closure procs ff cf fk ck)) + ) + + + (* Dump dot file per procedure. *) + let write_dot file ext prog = + let fn {Proc.cfg} kid = + match CFG.vertices_for cfg kid with + | [k] -> + Option.map (fun p -> (Proc.Id.name p.Proc.id, fun ff -> Proc.fmt ff p)) + (Proc.IdHMap.tryfind prog.procs (CFG.label_of k).K.proc) + | _ -> + None + in + let write_proc p = + let fname = file ^ "." ^ (Proc.Id.name p.Proc.id) ^ ext in + let roots = [K.id p.Proc.entry; K.id p.Proc.exit] in + Library.with_out fname (CFG.write_dot_partitioned (fn p) p.Proc.cfg roots) + in + Proc.IdHMap.iter (fun _ p -> write_proc p) prog.procs + + + (* Marshalling ============================================================ *) + + (* copy Typ's to re-HashCons them *) + let rec copy_typ t = Typ.( + match desc t with + | Top -> mkTop + | Bool -> mkBool + | Named(s) -> mkNamed s + | Int(u,s) -> mkInt u s + | Float(s) -> mkFloat s + | Pointer(t) -> mkPointer (copy_typ t) + | Array(t,io,s) -> mkArray (copy_typ t) io s + | Structure(s,fs,i) -> mkStructure s (List.map (fun (f,t) -> (f, copy_typ t)) fs) i + | Union(s,fs,i) -> mkUnion s (List.map (fun (f,t) -> (f, copy_typ t)) fs) i + | Enum(s,ms,i) -> mkEnum s ms i + | Function(t,ts,b) -> mkFunction (copy_typ t) (List.map copy_typ ts) b + ) + + let copy_fld f = + let typ = copy_typ (Fld.typ f) in + let fld = Fld.name f in + try fst (Fld.find_by_name typ fld |> Option.get) + with Not_found -> failwithf "copy_fld: no fld %a in ty %a" Fld.fmt f Typ.fmt typ + + + (* copy Exp's to re-HashCons them *) + let rec copy_exp e = + copy_exp_desc (Exp.desc e) + and desc_copy_exp_desc d = + Exp.desc (copy_exp_desc d) + and copy_exp_desc d = Exp.( + match d with + | Var(x) -> mkVar x + | Nil -> nil + | App({HC.desc=Add(f)},e) -> mkAdd (copy_exp e) (copy_fld f) + | App({HC.desc=Sub(f)},e) -> mkSub (copy_exp e) (copy_fld f) + | App({HC.desc=App({HC.desc=Idx},i)},a) -> mkIdx (copy_exp a) (copy_exp i) + | Bas(t) -> mkBas (copy_typ t) + | Eq(e,f) -> mkEq (copy_exp e) (copy_exp f) + | Num(n) -> mkNum(n) + | Str(s) -> mkStr(s) + | Op1(o,a) -> mkOp1 o (desc_copy_exp_desc a) + | Op2(o,a,b) -> mkOp2 o (desc_copy_exp_desc a) (desc_copy_exp_desc b) + | Op3(o,a,b,c) -> mkOp3 o (desc_copy_exp_desc a) (desc_copy_exp_desc b) (desc_copy_exp_desc c) + | OpN(o,a) -> mkOpN o (Array.map desc_copy_exp_desc a) + | App _ | Add _ | Sub _ | Idx -> assert false (* malformed *) + ) + + let copy_inst i = + let copy_inst_desc i = I.( + match i with + | Load(x,l) -> Load(x, copy_exp l) + | Store(l,r) -> Store(copy_exp l, copy_exp r) + | Alloc(x,e) -> Alloc(x, copy_exp e) + | Free(e) -> Free(copy_exp e) + | Kill(_) -> i + | Move(x,l) -> Move(x, copy_exp l) + | Cast(x,t,e) -> Cast(x, copy_typ t, copy_exp e) + | Assume(e) -> Assume(copy_exp e) + | Assert(e) -> Assert(copy_exp e) + | Nop -> Nop + | Generic _ -> failwith "Unmarshaling Generic commands not supported" + ) + in + { I.desc= copy_inst_desc i.I.desc; pos= i.I.pos } + + let copy_cmnd ct = C.( + match ct with + | Inst(i) -> Inst(copy_inst i) + | Call(_) -> ct + | ICall({Call.proc; typ} as call) -> ICall({call with Call.proc= copy_exp proc; typ= copy_typ typ}) + ) + + let marshal ch p = + Var.marshal ch ; + Fld.marshal ch ; + K.Id.marshal ch ; + Proc.Id.marshal ch ; + Marshal.to_channel ch p [] + + let unmarshal ch = + L.incf 1 "( Program.unmarshal" ; + Timer.start unmarshal_tmr ; + (fun _ -> + Timer.stop unmarshal_tmr ; + L.decf 1 ") Program.unmarshal" + )<& let()=()in + Var.unmarshal ch ; + Fld.unmarshal ch ; + K.Id.unmarshal ch ; + Proc.Id.unmarshal ch ; + let p = Marshal.from_channel ch in + let reinit_cfg_edges p = + CFG.iter_edges + (fun _ -> ()) + (fun (v,e,v') -> + let e' = copy_cmnd e in + CFG.remove_edge p.Proc.cfg v e v' ; + CFG.add_edge p.Proc.cfg v e' v') + p.Proc.cfg + (K.id p.Proc.entry) ; + {p with Proc.fty= copy_typ p.Proc.fty} + in + Proc.IdHMap.iter (fun name proc -> + let proc = reinit_cfg_edges proc in + Proc.IdHMap.add p.procs name proc + ) p.procs ; + p + +end diff --git a/src/Program.mli b/src/Program.mli new file mode 100644 index 0000000..b07596f --- /dev/null +++ b/src/Program.mli @@ -0,0 +1,227 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Internal representation of programs *) + +open Library + +open Type +open Variable +open Expression +open SymbolicHeap + + +(** Source Code Positions *) +module Position : sig + + type t = { dir : string; file : string; line : int; col : int; } + + val compare : t -> t -> int + val equal : t -> t -> bool + val fmt : t formatter + +end + + +(** Instructions *) +module Inst : sig + + type desc = + | Load of Var.t * Exp.t (** [v = mem[e] ] *) + | Store of Exp.t * Exp.t (** [mem[e] = f ] *) + | Alloc of Var.t * Exp.t (** [v = alloc(e) ] *) + | Free of Exp.t (** [free(e) ] *) + | Kill of Vars.t (** [vs = nondet()] *) + | Move of Var.t * Exp.t (** [v = e ] *) + | Cast of Var.t * Typ.t * Exp.t (** [v = (T)e ] *) + | Assume of Exp.t + | Assert of Exp.t + | Nop + | Generic of spec + + and spec = { ghosts : Vars.t; pre : XSH.t; insts : desc list; post : XSH.t; } + + type t = private { desc : desc; pos : Position.t; } + + val fv : t -> Vars.t + val mv : t -> Vars.t + + val compare : t -> t -> int + val equal : t -> t -> bool + val fmt_desc : desc formatter + val fmt : t formatter + + val mk : desc -> Position.t -> t + +end + + +(** Procedure Calls *) +module rec Call : sig + + type 'a t = { + proc : 'a; (** callee *) + actuals : Var.t list; (** actual parameters *) + areturn : Var.t option; (** actual return variable *) + typ : Typ.t; (** expected function type of callee *) + targets : Proc.Id.t list; (** over-approximation of procedures to which call may resolve *) + } + + val mk : Proc.t -> Var.t list -> Var.t option -> Proc.t t + val args : Proc.t t -> Substitution.t * Var.t list + + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val fmt : ('a formatter) -> 'a t formatter + +end + + +(** Commands *) +and Cmnd : sig + + type t = + | Inst of Inst.t + | Call of Proc.Id.t Call.t + | ICall of Exp.t Call.t + + val append : t -> t -> t option + + val fv : t -> Vars.t + val mv : t -> Vars.t + + val compare : t -> t -> int + val equal : t -> t -> bool + val fmt : t formatter + +end + + +(** Control-Flow Points *) +and ControlPoint : sig + + module Id : sig + type t + include UniqueId.S with type uniq := t + val fmt : t formatter + end + + type sort = + | Entry (** entry point of a procedure, no predecessors *) + | Exit (** exit point of a procedure, no successors *) + | Return (** return site of a procedure call *) + | Cut (** destination of a backward jump *) + | Join (** two of more predecessors *) + | Fork (** two of more successors *) + + val fmt_sort : sort formatter + + type label + + val mk_label : ?sort:sort -> Position.t -> Proc.Id.t -> Id.t * label + val set_sort : label -> sort option -> label + + type t + + val id : t -> Id.t + val sort : t -> sort option + val pos : t -> Position.t + val proc : t -> Proc.Id.t + + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + val fmt : t formatter + +end + + +(** Control-Flow Graphs *) +and CFG : sig + include (Graph.GRAPH + with type Vertex.t = ControlPoint.t + and type index = ControlPoint.Id.t + and type v_label = ControlPoint.label + and type e_label = Cmnd.t) + + val add_block_edge : graph -> ControlPoint.t -> Inst.t list -> ControlPoint.t -> unit + +end + + +(** Procedures *) +and Proc : sig + + module Id : (sig + type t + include UniqueId.S with type data = string and type uniq := t + val name : t -> string + val fmt : t formatter + end) + module IdHMap : (HashMap.S with type key = Id.t) + + type t = { + id : Id.t; + fty : Typ.t; + formals : Var.t list; + freturn : Var.t option; + locals : Vars.t; + modifs : Vars.t; + accessed : Vars.t; + cfg : CFG.graph; + entry : ControlPoint.t; + exit : ControlPoint.t; + } + + val fv : t -> Vars.t + + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + val fmt : t formatter + +end + + +(** Programs *) +module Prog : sig + + type t = { + globals : Vars.t; (** global variables *) + main : Proc.Id.t; (** entry point of program *) + procs : Proc.t Proc.IdHMap.t; (** map from procedure names to procedures *) + global_setup : Proc.Id.t list; (** procedures to allocate and deallocate globals *) + inits : Proc.Id.t list; (** procedures for initialising globals *) + addr_taken : Proc.Id.t list; (** procedures whose address is taken *) + constants : int64 list; (** constants occurring in program *) + } + + val iter_procs : (Proc.Id.t -> Proc.t -> unit) -> t -> unit + + val map_procs : (Proc.t -> Proc.t) -> t -> t + + val fold_procs : (Proc.t -> 'z -> 'z) -> t -> 'z -> 'z + + (** fold inter ff cf fk ck x folds over x and applies ff to every proc, cf to every recursively called proc, + fk to every control point, and ck to every backward jump destination control point. If [inter] is set, + also folds over called procedures. *) + val fold_proc : + Proc.t Proc.IdHMap.t option -> + (Proc.t -> 'a -> 'a) -> (Proc.t -> 'a -> 'a) -> + (Proc.t -> ControlPoint.t -> 'a -> 'a) -> (Proc.t -> ControlPoint.t -> 'a -> 'a) -> + Proc.t -> 'a -> 'a + + val fold_cp : + Proc.t Proc.IdHMap.t option -> + (Proc.t -> 'b -> 'b) -> (Proc.t -> 'b -> 'b) -> + (Proc.t -> ControlPoint.t -> 'b -> 'b) -> (Proc.t -> ControlPoint.t -> 'b -> 'b) -> + Proc.t -> ControlPoint.t -> 'b -> 'b + + val write_dot : string -> string -> t -> unit + + val marshal : out_channel -> t -> unit + val unmarshal : in_channel -> t + +end + + +val unmarshal_tmr : Timer.t diff --git a/src/Prover.ml b/src/Prover.ml new file mode 100644 index 0000000..a3770a5 --- /dev/null +++ b/src/Prover.ml @@ -0,0 +1,1774 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Theorem prover for subtraction and entailment of symbolic heaps *) + +open Library + +open Variable +open Expression +module E = Exp +module S = Substitution +open SymbolicHeap + +module SSet = Set.Make(Substitution) + +module L = (val Log.std Config.vPrv : Log.LOG) + + + +(* Timing ====================================================================*) + +let subtract_tmr = Timer.create "Prover.subtract" +let entails_tmr = Timer.create "Prover.entails" +let inconsistent_tmr = Timer.create "Prover.inconsistent.Pure.inconsistent" +let ent_pure_tmr = Timer.create "Prover.ent_pure.Pure.impliesx" +let pure_valid_tmr = Timer.create "Prover.pure_valid" +let sub_inconsis_m_tmr = Timer.create "Prover.sub_inconsis_m.Pure.inconsistent" +let sub_inconsis_s_tmr = Timer.create "Prover.sub_inconsis_s.Pure.inconsistent" +let pure_normalize_tmr = Timer.create "Prover.Pure.normalize" +let sh_normalize_tmr = Timer.create "Prover.SH.normalize" + +module Pure = struct include Pure + + let inconsistent tmr ?parts x = + Timer.start tmr ; + let res = inconsistent ?parts x in + Timer.stop tmr ; + res + + let impliesx tmr ?parts x xb = + Timer.start tmr ; + let res = impliesx ?parts x xb in + Timer.stop tmr ; + res + +end + +module SH = struct include SH + + let normalize ?dnf ?init xsh = + Timer.start sh_normalize_tmr ; + let res = normalize ?dnf ?init xsh in + Timer.stop sh_normalize_tmr ; + res + +end + +module XSH = struct include XSH + + let normalize ?dnf ?init xsh = + Timer.start sh_normalize_tmr ; + let res = normalize ?dnf ?init xsh in + Timer.stop sh_normalize_tmr ; + res + +end + + + +(*============================================================================ + Initialization + ============================================================================*) + +let sub_count = ref 0 +let saved_count = ref 0 + +let cxt = Pure.mk () +let _cxt_ent_ls = Pure.mk () +let cxt_chk = Pure.mk () + + + +(*============================================================================ + Subtraction: Support types and combinators + ============================================================================*) + +(** Entailment judgments + ! UniversalS. Minuend |- ? eXistentialS. Subtrahend *> Remainder + and subtraction judgments + ! UniversalS. Minuend \- ? eXistentialS. Subtrahend *> Remainder + produce Remainder given the other components, which are represented by: *) +type judgment = { + ent: bool; (** form: true = entailment, false = subtraction *) + + us : Vars.t; (** (universal) variable context *) + mm : SH.t; (** minuend *) + xs : Vars.t; (** existential context *) + ss : SH.t; (** subtrahend *) + + pm : Pure.t; (** pure context for approximation of minuend *) + ps : Pure.partition; (** partition of pm for approximation of subtrahend *) + + nm : SH.t; (** minuend conjunct not yet conjoined to pm *) + ns : SH.t; (** subtrahend conjunct not yet conjoined to ps *) + + cc : SH.t; (** common conjunct that has already been subtracted *) + pv : SH.t; (** subtrahend conjunct to be checked by pure_valid *) +} + + +(* Formatting =============================================================== *) + +let fmt_us = Vars.fmt_embrace "@[! " " .@]@ " +let fmt_xs = Vars.fmt_embrace "@[? " " .@]@ " +(* let fmt_pure ff q = E.fmt ff (SH.pure_sf q) *) + +let fmt lab ff {us; mm; xs; ss} = + let (_,uniques) as fxt = SH.mk_fxt (xs,ss) in + let xs = if !Config.vVar > 0 then xs else Vars.diff xs uniques in + Format.fprintf ff "%s@[: @[%a%a@]@\n\\- @[%a%a@]@]" lab + (if !Config.vPrv < 9 then fun _ _ -> () else fmt_us) us + SH.fmt mm + (Vars.fmtp_embrace "@[? " " .@]@ " fxt) xs + (SH.fmtsp (if !Config.vPrv > 100 then SH.emp else mm) fxt) ss + +let fmt_sub ff ({ent} as goal) = fmt (if ent then "( ent" else "( sub") ff goal + + + +(* Proof Search Combinators ================================================= *) + +type result = Unknown | Success of XSH.t * back_cont +(* It would be preferable to use: + type result = (XSH.t * back_cont) option + but it requires -rectypes *) + +(* backtrack continuation, invoked when goal is unprovable *) +and back_cont = unit -> result + +(* success continuation, invoked when rule applies *) +type succ_cont = XSH.t -> back_cont -> result + +(* failure continuation, invoked when rule does not apply *) +type fail_cont = succ_cont -> back_cont -> result + +type sub_query = succ_cont -> fail_cont -> back_cont -> result + +type sub_rule = judgment -> sub_query + + +(* sub_query combinators *) +let succ_ r sk _ bk = sk r bk +let fail_ sk fk bk = fk sk bk +let back_ _ _ bk = bk () + +(* sub_rule combinators *) +let fail__ : sub_rule = fun _g -> fail_ + +(* search logging *) +let trying msg pp v fn g = + assert(true$> L.printf 7 ("trying "^^msg) pp v ); fn g msg pp v +let applying msg pp v = + assert(true$> L.printf 3 ("applying "^^msg) pp v ) +let failing msg pp v z = + assert(true$> L.printf 9 ("failing "^^msg) pp v ); z +let backtracking msg pp v z = + assert(true$> L.printf 3 ("backtracking "^^msg) pp v ); z + +(* sub_query combinators with logging *) +let succ r msg pp v : sub_query = fun sk fk bk -> + applying msg pp v ; + succ_ r sk fk (fun()-> backtracking msg pp v bk ()) + +let fail msg pp v : sub_query = failing msg pp v fail_ + +let back msg pp v : sub_query = backtracking msg pp v back_ + +(* try qry and apply fn to the remainder *) +let appl (qry: sub_query) fn msg pp v : sub_query = fun sk fk bk -> + applying msg pp v ; + qry (fun r -> sk (fn r)) fk (fun()-> backtracking msg pp v bk ()) + + +(* try qry and backtrack if it fails *) +let commit (qry: sub_query) sk _ bk : result = + qry sk (fun _ _ -> bk()) bk + +(* try to apply rule0 and if it fails try rule1 *) +let ( $+ ) (rule0: sub_rule) (rule1: sub_rule) (goal: judgment) + (sk:succ_cont) (fk:fail_cont) (bk:back_cont) : result = + rule0 goal sk (fun _ _ -> rule1 goal sk fk bk) bk + +(* try to apply rule0 to goal and if it fails try rule1 on (fn goal) *) +let seq_xfrm_on_fail fn (rule0: sub_rule) (rule1: sub_rule) (goal: judgment) + (sk:succ_cont) (fk:fail_cont) (bk:back_cont) : result = + rule0 goal sk (fun _ _ -> rule1 (fn goal) sk fk bk) bk + +(* try to apply rule0 and if it backtracks try rule1 *) +(* let ( $& ) (rule0: sub_rule) (rule1: sub_rule) (goal: judgment) *) +(* (sk:succ_cont) (fk:fail_cont) (bk:back_cont) : result = *) +(* rule0 goal sk fk (fun()-> rule1 goal sk fk bk) *) + +(* try qry0 and if it fails or backtracks try qry1 *) +(* let or_else (qry0: sub_query) (qry1: sub_query) *) +(* (sk:succ_cont) (fk:fail_cont) (bk:back_cont) : result = *) +(* qry0 sk (fun _ _ -> qry1 sk fk bk) (fun()-> qry1 sk fk bk) *) + +(* try to apply rule0 and if it fails or backtracks try rule1 *) +(* let ( $+& ) (rule0: sub_rule) (rule1: sub_rule) (goal: judgment) = *) +(* or_else (rule0 goal) (rule1 goal) *) + +(* try to apply rule0 and if it succeeds apply fn to the remainder *) +let try_then (qry: sub_query) fn msg pp v + (sk:succ_cont) (fk:fail_cont) (bk:back_cont) : result = + qry (fun x bk -> fn x msg pp v sk fk bk) fk bk +(* let ( $>> ) = try_then *) + +(* try to apply rule0 and if it succeeds apply fn to the remainder, + if fn backtracks, do no backtrack rule0 *) +let try_commit_then (qry: sub_query) fn msg pp v + (sk:succ_cont) (fk:fail_cont) (bk:back_cont) : result = + qry (fun x _ -> fn x msg pp v sk fk bk) fk bk +let ( $!> ) = try_commit_then + +type xsk = succ_cont -> succ_cont + +(* Note: Here, if [fn x ... next fk0 bk] backtracks, then the [bk] of the + previous [x] is invoked. This is suboptimal, it would be better to pass + [bk0] to [fn x ...] and accumulate the [bk]s passed to [next], composing + them to form the [bk] finally passed to [sk0]. But this would require + [bk]s to be composable, which they aren't. *) +let try_forall (kfold: ('x->xsk)->xsk) fn (z:XSH.t) msg pp v + (sk0:succ_cont) (fk0:fail_cont) (bk0:back_cont) : result = +(* let sk0 a = L.printf 10 "$>>> sk0"; sk0 a in *) +(* let fk0 a = L.printf 10 "$>>> fk0"; fk0 a in *) +(* let bk0 a = L.printf 10 "$>>> bk0"; bk0 a in *) + kfold (fun x next -> fun z bk -> +(* let next a = L.printf 10 "$>>> next"; next a in *) +(* let bk a = L.printf 10 "$>>> bk"; bk a in *) + fn x z msg pp v next fk0 bk + ) sk0 z bk0 + +type xfk = fail_cont -> fail_cont + +let try_exists (kfold: ('x->xfk)->xfk) fn msg pp v + (sk0:succ_cont) (_fk0:fail_cont) (bk0:back_cont) : result = +(* let sk0 a = L.printf 10 "$++& sk0"; sk0 a in *) +(* let bk0 a = L.printf 10 "$++& bk0"; bk0 a in *) + kfold (fun x next -> fun sk bk -> +(* let next a = L.printf 10 "$++& next"; next a in *) +(* let sk a = L.printf 10 "$++& sk"; sk a in *) +(* let bk a = L.printf 10 "$++& bk"; bk a in *) + fn x msg pp v sk (fun _ _ -> next sk bk) (fun()-> next sk bk) + ) (fun _ bk -> bk()) sk0 bk0 + + +(* Specializations for particular rules used below *) + +let pp_nop _ff () = () +(* let trying_pure_valid = trying "pure_valid%a" pp_nop () *) +let trying_s_inconsis_m = trying "sub_inconsis_m%a" pp_nop () +let trying_s_inconsis_s = trying "sub_inconsis_s%a" pp_nop () +let trying_s_emp = trying "sub_emp%a" pp_nop () +let trying_s_true = trying "sub_true%a" pp_nop () +(* let trying_s_did = trying "sub_did%a" pp_nop () *) +let trying_s_distrib_m = trying "sub_distrib_m%a" pp_nop () +let trying_s_distrib_s = trying "sub_distrib_s%a" pp_nop () + +let trying_s_split_ls = trying "sub_split_ls: @[%a@]" Ls.fmt + +let trying_s_pt_pt = + let func = + trying "sub_pt_pt:%a" (fun ff (m_pt,s_pt) -> + Format.fprintf ff "@[ %a@ |- %a@]" Pt.fmt m_pt Pt.fmt s_pt) in + fun m_pt s_pt -> func (m_pt,s_pt) + +let trying_s_ls_pt = + let func = + trying "sub_ls_pt %a" (fun ff (dir,ls,pt) -> + Format.fprintf ff "(%s):@[ %a@ |- %a@]" + (if dir then "front" else "back") Ls.fmt ls Pt.fmt pt) in + fun dir ls pt -> func (dir,ls,pt) + +(* let trying_s_emp_ls = trying "sub_emp_ls: @[%a@]" Ls.fmt *) +let trying_s_emp_lss = trying "sub_emp_lss%a" pp_nop () + +let trying_s_pt_ls = + let func = + trying "sub_pt_ls %a" (fun ff (dir,pt,ls) -> + Format.fprintf ff "(%s):@[ %a@ |- %a@]" + (if dir then "front" else "back") Pt.fmt pt Ls.fmt ls) in + fun dir pt ls -> func (dir,pt,ls) + +let trying_s_ls_ls = + let func = + trying "sub_ls_ls %a" (fun ff (dir,m_ls,s_ls) -> + Format.fprintf ff "(%s):@[ %a@ |- %a@]" + (if dir then "front" else "back") Ls.fmt m_ls Ls.fmt s_ls) in + fun dir m_ls s_ls -> func (dir,m_ls,s_ls) + + + +(*============================================================================ + First-Order Entailment + ============================================================================*) + +(** [ent_pure pm ps xs p] holds only if [pm] implies the pure subformula + of [?xs. p]. *) +let ent_pure {pm; mm; xs; ss= p} = + assert(true$> + L.incf 5 "( ent_pur@[e: @[%a%a@]@]" fmt_xs xs SH.fmt p ); + (fun b -> assert(true$> + L.decf 5 ") ent_pure: %B" b )) + <& + let try_ent_pure xs p = + (* convert to a boolean expression *) + let b = SH.pure_sf p in + let b = E.map (SH.Pf.normalize mm) b in + let xs = Vars.inter xs (E.fv b) in + Pure.impliesx ent_pure_tmr pm (xs, b) + in + let xs, p = SH.exists_elim (xs, p) + in + match try_ent_pure xs p with + | Some(b) -> b + | None -> + let xs, p = SH.normalize (xs, p) in + match try_ent_pure xs p with + | Some(b) -> b + | None -> false + + + +(*============================================================================ + Entailment of Patterns + ============================================================================*) + +let rec ent_patn m_patn xs s_patn = + assert(true$> + L.incf 18 "( ent_patn: %a |- %a%a" + Patn.fmt m_patn fmt_xs xs Patn.fmt s_patn ); + (fun b -> assert(true$> + L.decf 18 ") ent_patn: %B" b )) + <& + if Patn.equal m_patn s_patn then + true + else + false +(* Note: Reenable to treat lists monotonically in patterns. + let {Patn.params= m_params} = m_patn in + let args = Ends.map E.var (fun v -> (Type.Top, E.ovar v)) m_params in + let m_body = Patn.instantiate m_patn args in + let s_body = Patn.instantiate s_patn args in + let us = Vars.union (XSH.fv m_body) (XSH.fv s_body) in + let ys, m_body = XSH.exists_bind (Vars.union us xs) m_body in + let us = Vars.union us ys in + let zs, s_body = XSH.exists_bind (Vars.union us xs) s_body in + let xs = Vars.union xs zs in + let pm = !!cxt_ent_ls in + Pure.clear pm; + let ps = Pure.mk_partition pm in + let goal = {ent=true; us; pm; mm= m_body; xs; ps; ss= s_body; + nm= m_body; ns= s_body} in + match ent goal with + | Success(r,_) -> Some(XSH.exists_intro (zs, r)) + | Unknown -> None +*) + + + +(*ent========================================================================= + Entailment + ============================================================================*) + +and ent (goal: judgment) = + sub {goal with ent= true} + (fun rr bk -> + (* is_intuitionistic and is_empty are stronger on normalized formulas *) +(* Note: need to do something in lieu of normalization? *) +(* let rr = XSH.normalize rr in *) + (* M \- S *> R & R => emp ==> M |- S *) + if XSH.is_empty (XSH.normalize rr) +(* Note: sub_true should make this unnecessary + (* M \- S * tt *> R ==> M |- S * tt *) + || SH.Jnk.mem () goal.r +*) + then Success(rr,bk) + else bk()) + (fun _sk bk -> bk()) + (fun()-> Unknown) + + + +(*sub========================================================================= + Subtraction: Judgment Normalization and Well-Formedness, and Tracing + ============================================================================*) + +and sub (goal: judgment) sk fk bk : result = + + (* express subtrahend in terms of representatives of minuend *) + assert(true$> L.printf 20 "pre-simplify:@\n%a)@\n" fmt_sub goal ); + let goal = + if not Config.prv_simplify then goal else + let {mm; xs; ss; nm; ns} = goal in + let init = + SH.fold_exps (fun e init -> + match E.sort_of e with + | (Var.PointerSort | Var.OffsetSort) when Vars.disjoint xs (E.fv e) -> + SH.Pf.extend xs init e + | _ -> + init + ) ss mm in + let (_, mm), meqs' = SH.normalize_stem ~init (Vars.empty, mm) in + let (xs, ss), seqs' = SH.normalize_stem ~init:mm (xs, ss) in + let nm = SH.Pf.star (Exps.to_list meqs') nm in + let ns = SH.Pf.star (Exps.to_list seqs') ns in + {goal with mm; xs; ss; nm; ns} in + + (* extend pm and pv if there are new constraints *) + let {nm= nm0; ns= ns0} = goal in + let goal = + if nm0 = SH.emp && ns0 = SH.emp then + goal + else + let pm = Pure.extend goal.pm in + let pv = SH.star [ns0] goal.pv in + {goal with pm; nm= SH.emp; ns= SH.emp; pv} in + + (* conjoin consequences of the new minuend and subtrahend constraints *) + let goal = + if nm0 = SH.emp then goal + else + let ps, c, d = SH.pure_consequences (SH.star [nm0] goal.cc) in + let us = Vars.union goal.us ps in +(* L.printf 0 "nm: %a" SH.fmt nm0 ; *) +(* assert ( not (Pure.inconsistent ent_pure_tmr goal.pm) ) ; *) +(* L.printf 0 "conjoin m: %a" E.fmt (E.mkAnd [|c; d|]) ; *) + Pure.conjoin goal.pm (E.mkAnd [|c; d|]) ; +(* if Pure.inconsistent ent_pure_tmr goal.pm then *) +(* L.printf 0 "Inconsistent" ; *) + {goal with us} + in + let goal = + if ns0 = SH.emp then goal + else + let ps, c, d = SH.pure_consequences ns0 in + let xs = Vars.union goal.xs ps in + let cd = E.mkAnd [|c; d|] in +(* L.printf 0 "conjoin s: %a" E.fmt cd ; *) + Pure.conjoin ~parts:[goal.ps] goal.pm cd ; +(* if Pure.inconsistent ~parts:[goal.ps] ent_pure_tmr goal.pm then *) +(* L.printf 0 "Inconsistent" ; *) + {goal with xs} + in + (* Note: Delay conjoining nm to mm and ns to ss in callers of sub and wait + to conjoin here, after using the old mm and ss to refine the above calls + to pure_consequences? *) + + (* trace printing *) + incr sub_count ; + + let rsk = ref sk and rfk = ref fk and rbk = ref bk in + assert(true$> + let indent = L.latch_incf 3 "%a" fmt_sub goal in + let reset x = L.resetf 3 indent x in + let name = if goal.ent then "ent" else "sub" in + rsk := (fun r -> reset ") %s: %a" name XSH.fmt r ; sk r) ; + rfk := (fun k -> reset ") %s: failed" name ; fk k) ; + rbk := (fun() -> reset ") %s: backtracked" name ; bk()) + ); + let sk = !rsk and fk = !rfk and bk = !rbk in + + (* variable occurrence conditions on judgments *) + assert( Vars.disjoint goal.us goal.xs + || failwithf "contexts intersect: @[%a@]" Vars.fmt + (Vars.inter goal.us goal.xs) ); + assert( Vars.subset (SH.fv goal.mm) goal.us + || failwithf "unbound minuend vars: @[%a@]" Vars.fmt + (Vars.diff (SH.fv goal.mm) goal.us) ); + assert( Vars.subset (SH.fv goal.ss) (Vars.union goal.us goal.xs) + || failwithf "unbound subtrahend vars: @[%a@]" Vars.fmt + (Vars.diff (SH.fv goal.ss) (Vars.union goal.us goal.xs)) ); + + (* variable occurrence conditions on remainder *) + let sk r = + assert( Vars.subset (XSH.fv r) (Vars.union goal.us goal.xs) + || failwithf "unbound remainder vars: @[%a@] in@ @[%a@]" + Vars.fmt (Vars.diff (XSH.fv r) (Vars.union goal.us goal.xs)) + (fmt "goal") goal ); + sk r in + + try + sub_ goal sk fk bk + with Exp.IllSorted _ -> + fail_ sk fk bk + + +and sub_ (goal: judgment) = + + +(*============================================================================ + Subtraction: Logical Axioms + ============================================================================*) + + let check_pure_valid goal = + if not Config.prv_valid_check then fail_ else + let {pm; xs; pv} = goal in +(* L.printf 0 "pv : %a" SH.fmt pv ; *) + if SH.equal SH.emp pv then + fail_ +(* else if Pure.inconsistent sub_inconsis_m_tmr pm then *) +(* succ_ XSH.ff *) + else ( + let xs, pv' = SH.exists_elim (xs, pv) in +(* L.printf 0 "pv': %a" SH.fmt pv' ; *) + let ps, c, d = SH.pure_consequences pv' in + let bex = E.mkAnd [|c; d|] in + let bex = +(* (L.incf 0 "( remove:@ {@[%a@]}@ %a" Vars.fmt xs E.fmt bex ; *) + E.remove (function + | E.Var(x) -> Vars.mem x xs + | _ -> false + ) bex +(* &> L.decf 0 ") remove: %a" E.fmt) *) + in +(* L.printf 0 "bex: %a" E.fmt bex ; *) + (* Note: Is this too strong, causing Pure.impliesx trouble with + quantification of ps? *) + let xs = Vars.union xs ps in + let xs = Vars.inter xs (E.fv bex) in + if Pure.impliesx pure_valid_tmr pm (xs, bex) = Some(false) then ( + assert(true$> L.printf 3 "backtracking pure_valid" ); + back_ + ) else + fail_ + ) + in + let pure_valid = + seq_xfrm_on_fail (fun g -> {g with pv= SH.emp}) check_pure_valid + in + + + (* M |- ff + ------------------ + M \- xs. S *> ff + *) + let sub_inconsis_m logical : sub_rule = trying_s_inconsis_m (fun goal -> + let {mm; pm} = goal in + if (if logical + then Pure.inconsistent sub_inconsis_m_tmr pm + else SH.inconsistent mm) + then succ XSH.ff + else fail + ) + in + + + (* S |- ff + ---------------- + M \- xs. S ~/> + *) + let sub_inconsis_s logical : sub_rule = trying_s_inconsis_s (fun goal -> + let {ss; pm; ps} = goal in + if logical then + if Pure.inconsistent sub_inconsis_s_tmr pm ~parts:[ps] + then back + else fail + else + if SH.inconsistent ss + then appl (sub_inconsis_m true goal) (fun r -> r) + else fail + ) + in + + + (* S |- emp [M] |- ?xs. S + -------------------------- + M \- xs. S *> M * S + + S |- emp [M] |/- ?xs. S + --------------------------- + M \- xs. S ~/> + *) + let sub_emp = trying_s_emp (fun goal -> + let {mm; ss} = goal in + if not (SH.is_empty ss) + then fail + else if ent_pure goal + then succ (SH.exists_intro Vars.empty (SH.star [ss] mm)) + else back + ) + in + + + (* is_pure(S) [M] |- ?xs. S + -------------------------------------- + M \- xs. S *> M M |- xs. S *> [M] + + is_pure(S) [M] |/- ?xs. S + ----------------------------- + M \- xs. S ~/> + + This assumes, for completeness, that no cut formulas are intuitionistic. + If cut formulas are intuitionistic, then in the entailment case + remainders with footprints between [M] and M may be necessary. + *) + let sub_true = trying_s_true (fun goal -> + let {ent; mm; ss} = goal in + if not (SH.is_pure ss) + then fail + else if ent_pure goal + then if ent then succ (XSH.Pf.star [SH.pure_sf mm] XSH.emp) + else succ (SH.exists_intro Vars.empty mm) + else back + ) + in + + +(*============================================================================ + Subtraction: Logical Rules + ============================================================================*) + + (* us. M \- xs. S *> R + ----------------------------- Q != _ * tt + us. Q * M \- xs. Q * S *> R + *) + let sub_did goal = + let {mm= q_m; ss= q_s; cc} = goal in + let mm, q, ss as mqs = SH.diff_inter_diff ~pas:false q_m q_s in + let mm, q, ss = + if SH.Jnk.is_empty q then + mqs + else + (SH.Jnk.star mm, SH.Jnk.remove q, SH.Jnk.star ss) in + if SH.is_empty q then + fail_ + else + let cc = SH.star [q] cc in + appl (sub {goal with mm; ss; cc}) (fun r -> r) "s_did: %a" SH.fmt q + in + + + (* us. Q0 * M \- xs. S *> R0 … us. QN * M \- xs. S *> RN + --------------------------------------------------------- + us. (Q0 v…v QN) * M \- xs. S *> R0 v…v RN + *) + (* Note: Choose which disjunction to distribute based on proving equations + between may-allocs, similar to sub_split_ls. Also simultaneously + distribute the subtrahend disjunction containing the alloc. *) + let sub_distrib_m q0_qN = trying_s_distrib_m (fun goal -> + let {mm= q0_qN_m; nm} = goal in + let m = SH.DjS.remove q0_qN q0_qN_m in + try_forall (Dj.kfold q0_qN) (fun qI r -> + assert(true$> L.printf 6 "s_distrib_m considering:@ %a" SH.fmt qI ); + let qI_m = SH.star [qI] m in + let nm = SH.star [qI_m] nm in + appl (sub {goal with mm= qI_m; nm}) (fun rI -> + XSH.disj [rI] r + ) + ) XSH.ff + ) + in + + + (* us. M \- xs. QI * S *> R + ----------------------------------- + us. M \- xs. (Q0 v…v QN) * S *> R + *) + (* Note: Choose which disjunction to distribute based on proving equations + between may-allocs, similar to sub_split_ls. *) + let sub_distrib_s q0_qN = trying_s_distrib_s (fun goal -> + let {ss= q0_qN_s; ns} = goal in + let s = SH.DjS.remove q0_qN q0_qN_s in + try_exists (Dj.kfold q0_qN) (fun qI -> + assert(true$> L.printf 6 "s_distrib_s considering:@ %a" SH.fmt qI ); + let qI_s = SH.star [qI] s in + let ns = SH.star [qI_s] ns in + appl (sub {goal with ss= qI_s; ns}) (fun r -> r) + ) + ) + in + + +(*============================================================================ + Subtraction: Theory-specific Rules + ============================================================================*) + + (* us. 0=k ^ f=n ^ b=p * M \- xs. S *> R0 + us. 0 R1 + ---------------------------------------------- + us. ls(L,k,p,f,b,n) * M \- xs. S *> R0 \/ R1 + *) + let sub_split_ls ({Ls.len} as ls) = trying_s_split_ls ls (fun goal -> + let {ent; mm= ls_m; nm} = goal in + (* check if len has already been split on *) + if SH.Pf.mem (E.mkZLt E.zero len) ls_m then + fail + else + let m = SH.LsS.remove ls ls_m in + let eqs = Ls.empty_eqs ls in +(* L.printf 0 "eqs: %a" E.fmt_b (E.band eqs) ; *) + let eqs_m = SH.Pf.star eqs m in +(* L.printf 0 "eqs_m: %a" SH.fmt eqs_m ; *) + let nm = SH.Pf.star eqs nm in + assert(true$> L.printf 3 "sub_split_ls empty:@ %a" Ls.fmt ls ); + (if ent then try_then else try_commit_then) + (commit (sub {goal with mm= eqs_m; nm})) (fun r0 -> + assert(true$> L.printf 6 "sub_split_ls non-empty:@ %a" Ls.fmt ls ); + let ineq = SH.Pf.star [E.mkZLt E.zero len] SH.emp in + let ineq_ls_m = SH.star [ineq] ls_m in + appl (commit (sub {goal with mm= ineq_ls_m; nm= ineq})) (fun r1 -> + XSH.disj [r0] r1 + ) + ) + ) + in + + + (* us. M \- xs. r0==r1 * S *> R + ------------------------------------- + us. l->r0 * M \- xs. l->r1 * S *> R + *) + let sub_pt_pt m_pt s_pt = trying_s_pt_pt m_pt s_pt (fun goal -> + let {Pt.off= o0; cnt= r0} = m_pt in + let {Pt.off= o1; cnt= r1} = s_pt in + let {mm= pt_m; ss= pt_s; ns; cc} = goal in + let m = SH.PtS.remove m_pt pt_m in + let s = SH.PtS.remove s_pt pt_s in + let oeq = E.mkEq (o0 :>Exp.t) (o1 :>Exp.t) in + let req = Option.to_list (Option.map2 E.mkEq r0 r1) in + let eqs = oeq :: req in + let eq_s = SH.Pf.star eqs s in + let ns = SH.Pf.star eqs ns in + let cc = SH.PtS.star [m_pt] cc in + appl (sub {goal with mm= m; ss= eq_s; ns; cc}) (fun r -> r) + ) + in + + + (* [empty_approx Q (xs,ys)] returns a formula [P] such that [Q |- P * tt] + and [P |- emp], and where every boolean subformula of [P] must mention one + of [xs] and none of [ys]. *) + let empty_approx q = + let pure_sf_q = SH.pure_sf q in + fun (xs,ys) -> +(* L.incf 0 "( empty_approx: {%a} %a" Vars.fmt xs SH.fmt q ; *) +(* L.printf 0 "[q]: %a" E.fmt_b pure_sf_q ; *) + E.remove (fun d -> + let b = E.name d in + E.is_boolean b + && (let vs = E.fv b in Vars.disjoint vs xs || Vars.intersect vs ys) + ) pure_sf_q +(* &> L.decf 0 ") empty_approx: %a" E.fmt_b *) + in + + + (* us. k=0 ^ f=n ^ b=p * M0 \- xs. P0 * e->r *> R0 + us,ys. M1 * M0 \- xs. P0 * e->r *> R1 + us,ws,zs. R01' \- xs-ws. S0 *> R + ----------------------------------------------------- + us. ls(L,k,p,f,b,n) * M0 \- xs. e->r * S0 *> ?zs. R + + where + e->r * S0 |= P0 * tt and P0 |= emp + ?ys. M1 = ?i,j. L(p,f,i,j) * ls(L,k-1,i,j,b,n) + ws = xs ∩ fv(e->r) (xs-ws = xs - fv(e->r)) + ?zs. R01' = ?xs-ws. R0 \/ ?ys. R1 + + applied when + ls(L,k,p,f,b,n) * M |- ?xs. e=f when dir = true + or ls(L,k,p,f,b,n) * M |- ?xs. e=b when dir = false + *) + (* Note: Is this premiss order optimal? *) + let sub_ls_pt dir ls0 pt0 = trying_s_ls_pt dir ls0 pt0 (fun goal -> + let {us; mm= ls_m0; xs; ss= pt_s0; nm; cc} = goal in + let m0 = SH.LsS.remove ls0 ls_m0 in + let s0 = SH.PtS.remove pt0 pt_s0 in + let mk_p0 = empty_approx pt_s0 in + let eqs = Ls.empty_eqs ls0 in + let eqs_m0 = SH.Pf.star eqs m0 in + let ws, xs_m_ws = Vars.inter_diff xs (Pt.fv pt0) in + let p0_pt = SH.Pf.star [mk_p0 (ws, xs_m_ws)] (SH.PtS.star [pt0] SH.emp) in + let nm = SH.Pf.star eqs nm in + let goal' = {goal with mm= eqs_m0; ss= p0_pt; nm; pv= SH.emp} in + assert(true$> L.printf 3 "s_ls_pt: empty case" ); + commit (sub goal') $!> (fun r0 -> + let {Ls.pat; len} = ls0 in + let _, pre, suf = Ls.split_on_fresh_point ls0 in + let link_args = if dir then pre else suf in + let ls1_args = if dir then suf else pre in + let us_xs = Vars.union us xs in + let _, link = XSH.exists_bind us_xs (Patn.instantiate pat link_args) in + let ls1 = {ls0 with Ls.len= E.mkZSub [|len; E.one|]; arg= ls1_args} in + let link_ls1 = SH.LsS.star [ls1] link in + let link_ls1_m0 = SH.star [link_ls1] m0 in + let ys = Vars.diff (SH.fv link_ls1) us_xs in + let us_ys = Vars.union us ys in + let goal' = {goal with us= us_ys; mm= link_ls1_m0; ss= p0_pt; + nm= link_ls1; pv= SH.emp} in + assert(true$> L.printf 3 "s_ls_pt: nonempty case" ); + commit (sub goal') $!> (fun r1 -> + let r01 = XSH.disj [r0] (XSH.exists_intro ys r1) in + let zs, r01' = XSH.exists_bind us_xs (XSH.exists_intro xs_m_ws r01) in + let us_ws_zs = Vars.union (Vars.union us ws) zs in + (* Note: This adds a subtrahend subformula to cc, is this ok, might it + contain existentials that then get pulled out of scope? *) + let cc = SH.PtS.star [pt0] cc in + let goal' = + {goal with us= us_ws_zs; mm= r01'; xs= xs_m_ws; ss= s0; nm= r01'; cc} + in + appl (commit (sub goal')) (fun r -> + XSH.exists_intro zs r + ) + ) + ) + ) + in + + + (* M |- ?xs. k=0 ^ f=n ^ b=p ^ P0 + us. M \- xs. k=0 ^ f=n ^ b=p * S *> R + --------------------------------------- + us. M \- xs. ls(L,k,p,f,b,n) * S *> R + + where + ls(L,k,p,f,b,n) * S |= P0 * tt and P0 |= emp + *) + (* Note: Assumes that ls has already been removed from goal.ss. *) + let sub_emp_ls_ goal ls p0 min_fk min_bk m p v sk maj_fk maj_bk = + let {ss= s0; ns} = goal in + let ls0 = SH.Pf.star (Ls.empty_eqs ls) SH.emp in + let ls0_p0 = SH.Pf.star [p0] ls0 in + if ent_pure {goal with ss= SH.Pf.star [SH.pure_sf ls0_p0] SH.emp} then + let ls0_s0 = SH.star [ls0] s0 in + let ns = SH.star [ls0] ns in + appl (sub {goal with ss= ls0_s0; ns}) (fun r -> + r + ) m p v sk maj_fk maj_bk + else + min_fk sk min_bk + in + + (* us. M \- xs. k0=0 ^ f0=n0 ^ b0=p0 ^…^ kN=0 ^ fN=nN ^ bN=pN * S *> R + ----------------------------------------------------------------------- + us. M \- xs. ls(L0,k0,p0,f0,b0,n0) *…* ls(LN,kN,pN,fN,bN,nN) * S *> R + *) + let sub_emp_lss : sub_rule = trying_s_emp_lss (fun goal -> + let {ss= lss_s; ns} = goal in + if SH.LsS.is_empty lss_s then fail else + let eqs, s = + SH.LsS.fold (fun ls (eql,s) -> + (List.rev_append (Ls.empty_eqs ls) eql, SH.LsS.remove ls s) + ) lss_s ([], lss_s) in + let eqs_s = SH.Pf.star eqs s in + let ns = SH.Pf.star eqs ns in + appl (sub {goal with ss= eqs_s; ns}) (fun r -> r) + ) + in + + + (* us. e->r * M \- xs,ys. P0 * S1 *> R0 + us,ws,zs. R0' \- xs-ws. S *> R + --------------------------------------------------- + us. e->r * M \- xs. ls(L,k,p,f,b,n) * S *> ?zs. R + + instantiated with each of + ?ys. S1 = k=1 ^ L(p,f,b,n) + ?ys. S1 = ?i,j. L(p,f,i,j) * ls(L,k-1,i,j,b,n) when dir = true + ?ys. S1 = ?i,j. ls(L,k-1,p,f,i,j) * L(i,j,b,n) when dir = false + + where + ls(L,k,p,f,b,n) * S |= P0 * tt and P0 |= emp + ws = xs ∩ fv(P0 * S1) (xs-ws = xs - fv(P0 * S1)) + ?zs. R0' = ?(xs-ws),ys. R0 + + applied when + e->r * M |- ?xs. e=f when dir = true + e->r * M |- ?xs. e=b when dir = false + + preceded by sub_emp_ls + *) + (* Note: It may seem to be equivalent and provide tighter control on the + search space to change + ?ys. S1 = ?i,j. L(p,f,i,j) * ls(L,k-1,i,j,b,n) + to + ?ys. S1 = ?i,j. k>1 * L(p,f,i,j) * ls(L,k-1,i,j,b,n) + but this introduces incompleteness. The models of the minuend may not + all fall into one of the empty, single, and so modified multiple cases. + *) + (* Note: Is distinguishing between k=1 and k>1 cases worthwhile? No, at + least unless the major premiss can be committed in the empty case. *) + let sub_pt_ls dir pt ls = trying_s_pt_ls dir pt ls (fun goal m p v sk fk bk -> + let {Ls.pat; len} = ls in + let {ent; us; xs; ss= ls_s0; nm; ns; cc} = goal in + let us_xs = Vars.union us xs in + let s0 = SH.LsS.remove ls ls_s0 in + let p0 = empty_approx ls_s0 (Vars.inter_diff xs (Ls.fv ls)) in + + let major ws xs_m_ws ys sk maj_fk maj_bk = fun r0 bk -> + let xs = xs_m_ws in + let xys = Vars.union xs ys in + let zs, r0' = XSH.exists_bind us_xs (XSH.exists_intro xys r0) in +(* L.printf 0 "xs-ws:@ {%a}@\n ys:@ {%a}@\n r0:@ %a@\nr0':@ %a" *) +(* Vars.fmt xs_m_ws Vars.fmt ys XSH.fmt r0 SH.fmt r0' ; *) + let us = Vars.union (Vars.union us ws) zs in + let nm = SH.star [r0'] nm in + let cc = SH.LsS.star [ls] cc in + appl (sub {goal with us; mm= r0'; xs; ss= s0; nm; cc}) (fun r -> + XSH.exists_intro zs r + ) m p v sk (maj_fk bk) (maj_bk bk) + in + + let multiple_case min_fk min_bk maj_fk maj_bk = + let _, pre, suf = Ls.split_on_fresh_point ls in + let link_args = if dir then pre else suf in + let ls2_args = if dir then suf else pre in + let _, link = XSH.exists_bind us_xs (Patn.instantiate pat link_args) in + let ls2 = {ls with Ls.len= E.mkZSub [|len; E.one|]; arg= ls2_args} in + let lsM = SH.LsS.star [ls2] link in + let p0_lsM = SH.Pf.star [p0] lsM in + let fv_s1 = SH.fv lsM in + let ys = Vars.diff fv_s1 us_xs in + let xys = Vars.union xs ys in + let fv_p0_s1 = SH.fv p0_lsM in + let ws, xs_m_ws = Vars.inter_diff xs fv_p0_s1 in + let ns = SH.star [p0_lsM] ns in + assert(true$> L.printf 3 "s_pt_ls: multiple case" ); + sub {goal with xs= xys; ss= p0_lsM; ns; pv= SH.emp} + (major ws xs_m_ws ys sk maj_fk maj_bk) min_fk min_bk + in +(* + let single_case min_fk min_bk maj_fk maj_bk = + let ys, link = XSH.exists_bind us_xs (Patn.instantiate pat arg) in + let ls1 = SH.Pf.star [E.eq_v len E.one] link in + let xys = Vars.union xs ys in + let fv_s1 = SH.fv ls1 in + let ws, xs_m_ws = Vars.inter_diff xs fv_s1 in + let p0_ls1 = SH.Pf.star [p0] ls1 in + let ns = SH.star [p0_ls1] ns in + L.printf 3 "s_pt_ls: single case" ; + sub {goal with xs= xys; ss= p0_ls1; ns; pv= SH.emp} + (major ws xs_m_ws ys sk maj_fk maj_bk) min_fk min_bk + in +*) + let empty_case min_fk min_bk fk bk = + assert(true$> L.printf 3 "s_pt_ls: empty case" ); + let goal = {goal with ss= s0} in + sub_emp_ls_ goal ls p0 min_fk min_bk m p v sk fk bk + in + + if ent then + let multiple_case bk () = + multiple_case + (* continue after rule if minor premiss fails or backtracks *) + fk bk + (* continue after rule if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + (fun _bk -> fk) (fun _bk -> bk) + in + let empty_case bk () = + empty_case + (* continue with multiple case if minor premiss fails or backs *) + (fun _sk _bk -> multiple_case bk ()) (multiple_case bk) + (* continue with multiple case if major premiss fails or backs *) + (* Note: verify conjecture that committing here is incomplete *) + (fun _sk _bk -> multiple_case bk ()) (fun _bk -> multiple_case bk ()) + in + empty_case bk () +(* This premiss order is uniformly slower experimentally: + let empty_case bk () = + empty_case + (* continue after rule if minor premiss fails or backtracks *) + fk bk + (* continue after rule if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + fk bk + in + let multiple_case bk () = + multiple_case + (* continue with empty case if minor premiss fails or backs *) + (fun _sk _bk -> empty_case bk ()) (empty_case bk) + (* continue with empty case if major premiss fails or backs *) + (* Note: verify conjecture that committing here is incomplete *) + (fun _sk _bk bk -> empty_case bk ()) (fun bk -> empty_case bk) + in + multiple_case bk () +*) + else + let multiple_case() = + multiple_case + (* continue after rule if minor premiss fails or backtracks *) + fk bk + (* backtrack rule if major premiss fails, continue if it backtracks *) + (* Note: verify conjecture that this is complete *) + (fun _ _ _ -> bk()) (fun bk -> bk) + in + let empty_case() = + empty_case + (* continue with multiple case if minor premiss fails or backtracks *) + (fun _ _ -> multiple_case()) multiple_case + (* continue with multiple case if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + (fun _ _ -> multiple_case()) multiple_case + in + empty_case() + ) + in + + + (* K |- L + us,vs. M1 * M \- xs-vs,ys. P0 * S1 *> R0 + us. 0=i ^ e=m ^ a=o * M \- xs. P0 * ls(L,j,p,f,b,n) *> R1 + us,ws,zs. R01' \- xs-ws. S *> R + -------------------------------------------------------------- + us. ls(K,i,o,e,a,m) * M \- xs. ls(L,j,p,f,b,n) * S *> ?zs. R + + instantiated with: + M1 = 0 + let {Ls.len= m_len; arg= m_arg; pat= m_patn} = m_ls in + let {Ls.len= s_len; arg= s_arg; pat= s_patn} = s_ls in + let {ent; us; mm= ls_m0; xs; ss= ls_s0; nm; ns; cc} = goal in + let m0 = SH.LsS.remove m_ls ls_m0 in + let s0 = SH.LsS.remove s_ls ls_s0 in + let p0 = empty_approx ls_s0 (Vars.inter_diff xs (Ls.fv s_ls)) in + + let equal_eqs m_arg s_arg = + Args.fold_links2 (fun (e,m) (f,n) eqs -> + E.mkEq e f :: E.mkEq m n :: eqs + ) m_arg s_arg [] + in + + let major_premiss vs ws xs_m_ws r0 maj_fk maj_bk = fun r1 bk -> + let us_xs = Vars.union us xs in + let r01 = XSH.set_lbl (SH.lbl m0) (XSH.disj [XSH.exists_intro vs r0] r1) in + let zs, r01' = XSH.exists_bind us_xs (XSH.exists_intro xs_m_ws r01) in + let us_ws_zs = Vars.union (Vars.union us ws) zs in + let nm = SH.star [r01'] nm in + let cc = SH.LsS.star [s_ls] cc in + let goal = {goal with us= us_ws_zs; mm= r01'; xs= xs_m_ws; ss= s0; nm; cc} in + appl (sub goal) (fun r -> + XSH.exists_intro zs r + ) m p v sk (maj_fk bk) (maj_bk bk) + in + + let empty_minuend_ls_premiss vs ws xs_m_ws p0 maj_fk maj_bk = fun r0 bk -> + assert(true$> L.printf 3 "s_ls_ls: empty minuend ls premiss" ); + let m2 = SH.Pf.star (Ls.empty_eqs m_ls) SH.emp in + let m2_m0 = SH.star [m2] m0 in + let s2 = SH.LsS.star [s_ls] p0 in + let nm = SH.star [m2] nm in + let goal = {goal with mm= m2_m0; ss= s2; nm; pv= SH.emp} in + sub goal (major_premiss vs ws xs_m_ws r0 maj_fk maj_bk) fk bk + in + + let nonempty_minuend_ls_premiss m1 xs s1 min_fk min_bk maj_fk maj_bk = + assert(true$> L.printf 3 "s_ls_ls: nonempty minuend ls premiss" ); + let vs = Vars.diff (SH.fv m1) us in + let xs_m_vs = Vars.diff xs vs in + let us_vs = Vars.union us vs in + let m1_m0 = SH.star [m1] m0 in + let p0 = SH.Pf.star [p0] SH.emp in + let p0_s1 = SH.star [p0] s1 in + let ws, xs_m_ws = Vars.inter_diff xs (SH.fv p0_s1) in + let nm = SH.star [m1] nm in + let ns = SH.star [p0_s1] ns in + let goal = {goal with us= us_vs; mm= m1_m0; xs= xs_m_vs; ss= p0_s1; nm; ns; pv= SH.emp} in + sub goal (empty_minuend_ls_premiss vs ws xs_m_ws p0 maj_fk maj_bk) min_fk min_bk + in + + let long_case min_fk min_bk maj_fk maj_bk = + assert(true$> L.printf 3 "s_ls_ls: longer subtrahend ls case" ); + let presuffix, arg = Args.remove dir m_arg s_arg in + let len = E.mkZSub [|s_len; m_len|] in + let s_m_ls = {s_ls with Ls.len; arg} in + let m1 = SH.Pf.star [E.mkZLt E.zero m_len] SH.emp in + let s1 = SH.Pf.star (Args.cycle_eqs presuffix) + (SH.LsS.star [s_m_ls] SH.emp) in + nonempty_minuend_ls_premiss m1 xs s1 min_fk min_bk maj_fk maj_bk + in + + let short_case min_fk min_bk maj_fk maj_bk = + assert(true$> L.printf 3 "s_ls_ls: shorter subtrahend ls case" ); + let s_len' = E.mkVar (Var.gensym "k" Var.IntegerSort) in + let len = E.mkZSub [|m_len; s_len'|] in + let _, pre, suf = Ls.split_on_fresh_point m_ls in + let m_s_ls = {m_ls with Ls.len; arg= if dir then suf else pre} in + let m1 = SH.Pf.star [E.mkZLt E.zero s_len'] (SH.LsS.star [m_s_ls] SH.emp) in + let s1 = SH.Pf.star (E.mkEq s_len s_len' + :: equal_eqs (if dir then pre else suf) s_arg) SH.emp in + nonempty_minuend_ls_premiss m1 xs s1 min_fk min_bk maj_fk maj_bk + in + + let equal_case min_fk min_bk maj_fk maj_bk = + assert(true$> L.printf 3 "s_ls_ls: equal length ls case" ); + let m1 = SH.Pf.star [E.mkZLt E.zero m_len] SH.emp in + let s1 = SH.Pf.star (E.mkEq m_len s_len + :: equal_eqs m_arg s_arg) SH.emp in + nonempty_minuend_ls_premiss m1 xs s1 min_fk min_bk maj_fk maj_bk + in + + let empty_case min_fk min_bk maj_fk maj_bk = + assert(true$> L.printf 3 "s_ls_ls: empty subtrahend ls case" ); + let goal = {goal with ss= s0} in + sub_emp_ls_ goal s_ls p0 min_fk min_bk m p v sk maj_fk maj_bk + in + + if not (ent_patn m_patn xs s_patn) then fail_ sk fk bk else + + (* Note: Is this premiss order optimal? *) + if ent then + (* maximize footprint of subtrahend when proving entailment *) + let empty_case bk () = + empty_case + (* continue after rule if minor premiss fails or backtracks *) + fk bk (* (fun () -> fk sk bk) *) + (* continue after rule if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + fk bk + in + let short_case bk () = + short_case + (* continue with long case if minor premisses fail or backtrack *) + (fun _sk _bk -> empty_case bk ()) (empty_case bk) + (* continue with long case if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + (fun bk _sk _bk -> empty_case bk ()) (fun _bk -> empty_case bk) + in + let long_case () = + long_case + (* continue with short case if minor premisses fail or backtrack *) + (fun _sk bk -> short_case bk ()) (short_case bk) + (* continue with short case if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + (fun bk _sk _bk -> short_case bk ()) (fun _bk -> short_case bk) + in + long_case() + else + let long_case() = + long_case + (* continue after rule if minor premisses fail or backtrack *) + fk bk (* (fun () -> fk sk bk) *) + (* backtrack whole rule if major premiss fails or backtracks *) + (* Note: verify conjecture that this is complete *) + (fun _ _ _ -> bk()) (fun bk -> bk) + in + let short_case() = + short_case + (* continue with long case if minor premiss fails or backtracks *) + (fun _ _ -> long_case()) long_case + (* continue with long case if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + (fun _ _ _ -> long_case()) (fun _ -> long_case) + in + let equal_case() = + equal_case + (* continue with short case if minor premisses fail or backtrack *) + (fun _ _ -> short_case()) short_case + (* continue with short case if major premisses fail or backtrack *) + (* Note: verify conjecture that committing here is incomplete *) + (fun _ _ _ -> short_case()) (fun _ -> short_case) + in + let empty_case() = + empty_case + (* continue with equal case if minor premiss fails or backtracks *) + (fun _ _ -> equal_case()) equal_case + (* continue with equal case if major premiss fails or backtracks *) + (* Note: verify conjecture that committing here is incomplete *) + (fun _ _ -> equal_case()) equal_case + in + empty_case() + ) + in + + + +(*============================================================================ + Subtraction: Proof Search Algorithm + ============================================================================*) + + (* stub *) + let find_witnesses _ _ = S.empty +(* + let find_witnesses {pm; mm; xs; ps; ss} s_loc = + let xs_s_loc = Vars.inter xs (E.fv s_loc) in + if Vars.is_empty xs_s_loc then + S.empty + else if not !prv_wbn then + let es = + Array.of_list (Vars.fold (fun x es -> E.mkVar x :: es) xs_s_loc []) in + let car = Exps.union (SH.carrier mm) (SH.carrier ss) in + let car = + Exps.filter (fun e -> + match E.sort_of e with + | Var.OffsetSort | Var.ValueSort -> Vars.disjoint (E.fv e) xs + | _ -> false + ) car in + Pure.forced_equalities ~parts:[ps] pm E.compare es car + &> L.printf 6 "found witnesses: %a" S.fmt + else + (* Note: Avoid this call to Pure.normalize by extracting witnesses from + the proof from the preceding Pure.implies call? *) + (* Note: Refactor: this is mostly copied from SymbolicHeap.choose_rep *) + let cmp e f = + let num_xs e = Vars.cardinal (Vars.inter xs (E.fv e)) in + let ord = Pervasives.compare (num_xs e) (num_xs f) in + if ord <> 0 then ord else E.compare e f in + let choose_rep cls = + Exps.fold (fun e m -> + if cmp e m < 0 then e else m + ) cls (Exps.choose cls) + in + let car = Exps.union (SH.carrier mm) (SH.carrier ss) in + let car = + Exps.filter (fun e -> + match E.sort_of e with + | Var.OffsetSort | Var.ValueSort -> Vars.disjoint (E.fv e) xs + | _ -> false + ) car in + let car = + Vars.fold (fun x car -> Exps.add (E.mkVar x) car) xs_s_loc car in + match Pure.normalize ~parts:[ps] pm choose_rep car with + | None -> S.empty + | Some(rep, _) -> + Vars.fold (fun x ws -> + let xexp = E.mkVar x in + match S.tryfind xexp rep with + | Some(xrep) when Vars.disjoint (E.fv xrep) xs -> S.add xexp xrep ws + | _ -> ws + ) xs_s_loc S.empty + &> L.printf 6 "found witnesses: %a" S.fmt +*) + in + + (* M ^ |S| |- e==f + us,vs. Ws=ys * M \- xs-vs. e==f ^ S[e,Ws/f,ys] *> R + ----------------------------------------------------- + us. M \- xs. S *> R + + where + ys ⊆ xs + vs = xs ∩ fv(Ws=ys) (xs-vs = xs - fv(Ws=ys)) + *) + let _find_provable_equality m_locs s_locs keep goal = + let {pm; us; mm; xs; ps; ss; nm} = goal + and keep = Lazy.force keep + in + match Pure.find_provable_equality ~parts:[ps] pm m_locs s_locs keep with + | Pure.Equality(m_loc, s_loc) as eq -> +(* L.printf 0 "proved: %a = %a" E.fmt_v m_loc E.fmt_v s_loc ; *) + (* find witnesses of existentials in s_loc *) + let witnesses = find_witnesses goal s_loc in + (* conjoin equalities witnesses to minuend *) + let goal = + if S.is_empty witnesses then + goal + else + let witness_b = S.to_exp witnesses in + let vs = E.fv witness_b in + let us = Vars.union us vs in + let xs = Vars.diff xs vs in + let mm = SH.Pf.star [witness_b] mm in + let nm = SH.Pf.star [witness_b] nm in + {goal with us; mm; xs; nm} in + (* express subtrahend ito witnesses and m_loc for s_loc *) + let witnesses = S.add s_loc m_loc witnesses in + let ss = SH.Pf.star [E.mkEq s_loc m_loc] (SH.subst witnesses ss) in + (eq, {goal with ss}) + | res -> + (res, goal) + in + + + let find_syntactic_equality m_locs s_locs _ goal = + try + let loc = Exps.min_elt (Exps.inter m_locs s_locs) in + (Pure.Equality(loc, loc), goal) + with Not_found -> + (Pure.Disjunctions([]), goal) + in + + + (* choose a rule instance to apply to subtract a pt *) + let chs_pts find_equiv_and_witnesses ({mm; xs; ss} as goal) = + assert(true$> L.printf 8 "chs_pts" ); + let m_locs = SH.may_allocs_stem mm in + let s_locs = SH.PtS.may_allocs ss in + let keep = lazy ( + let s_djs_xs = + Vars.inter xs + (SH.DjS.fold (fun dj vs -> + Vars.union (Dj.fv dj) vs + ) ss Vars.empty) in + fun m_loc s_loc -> + (* don't try trivial equalities, they have been handled already *) + not (E.equal m_loc s_loc) + (* don't try to match a subtrahend pt with existentials in common with + the subtrahend djs with a minuend ls *) + && (Vars.disjoint (Pt.fv (SH.PtS.find s_loc ss)) s_djs_xs + || (match SH.find m_loc mm with SH.Pt _ -> true | _ -> false) ) + ) + in + match find_equiv_and_witnesses m_locs s_locs keep goal with + | Pure.Equality(loc,_), ({mm; ss} as goal) -> + let s_pt = SH.PtS.find loc ss in + (match SH.find loc mm with + | SH.Pt(m_pt) -> + assert(true$> + L.printf 6 "chs_pts match m_pt:@[ %a@ |- %a@]" + Pt.fmt m_pt Pt.fmt s_pt ); + commit (sub_pt_pt m_pt s_pt goal) + | SH.Ls(m_ls) -> + assert(true$> + L.printf 6 "chs_pts match m_ls:@[ %a@ |- %a@]" + Ls.fmt m_ls Pt.fmt s_pt ); + (* since sub_ls_pt considers the case where the minuend ls is + empty, even if multiple minuend may-allocs are equal to loc, + committing does not introduce incompleteness *) + commit (sub_ls_pt (Ls.direction m_ls loc) m_ls s_pt goal) + | _ -> failwith "chs_pts: case split needed?" + ) + | Pure.Disjunctions(djs), _ -> + assert(true$> if djs <> [] then + L.printf 6 "chs_pts: case split: [%a]" + (List.fmt ";@ " (fun ff efl -> + Format.fprintf ff "[%a]" + (List.fmt ";@ " (fun ff (e,f) -> + Format.fprintf ff "%a = %a" E.fmt e E.fmt f)) efl)) djs ); + let djs = List.fast_sort (List.compare_lex (fun _ _ -> 0)) djs in + List.kfold (fun dj (next_dj : sub_rule) -> + let locs = + List.fold (fun (e,f) locs -> Exps.add e (Exps.add f locs)) + dj Exps.empty in + Exps.kfold locs (fun loc (next_loc : sub_rule) -> + try sub_split_ls (SH.LsS.find loc mm) $+ next_loc + with Not_found -> next_loc + ) next_dj + ) djs fail__ goal + | Pure.Inconsistent, _ -> + assert(true$> L.printf 6 "chs_pts: inconsistent" ); + commit ((sub_inconsis_m true $+ sub_inconsis_s true) goal) + in + + + (* choose a rule instance to apply to subtract a ls *) + (* Note: try sub_pt_ls with lists with universal lengths first *) + let chs_lss find_equiv_and_witnesses ({mm; ss} as goal) = + assert(true$> L.printf 8 "chs_lss" ); + let m_pt_locs = SH.PtS.may_allocs mm in + let m_ls_locs = SH.LsS.may_allocs mm in + let s_locs = SH.LsS.may_allocs ss in + let keep = lazy (fun m_loc s_loc -> not (E.equal m_loc s_loc)) + in + (* first try to find a matching pt *) + match find_equiv_and_witnesses m_pt_locs s_locs keep goal with + | Pure.Equality(loc,_), ({mm; ss} as goal) -> + let s_ls = SH.LsS.find loc ss in + let m_pt = SH.PtS.find loc mm in + assert(true$> + L.printf 6 "chs_lss match m_pt:@[ %a@ |- %a@]" + Pt.fmt m_pt Ls.fmt s_ls ); + (* since sub_pt_ls considers the case where minuend lists are + empty, even if multiple minuend may-allocs are equal to loc, + committing does not introduce incompleteness *) + commit (sub_pt_ls (Ls.direction s_ls loc) m_pt s_ls goal) + | Pure.Inconsistent, _ -> + assert(true$> L.printf 6 "chs_lss: Inconsistent" ); + (* chs_lss only called after sub_inconsis_m, so just backtrack here *) + commit back_ + | Pure.Disjunctions([]), _ -> + (* second try to find a matching ls *) + (match find_equiv_and_witnesses m_ls_locs s_locs keep goal with + | Pure.Equality(loc,_), ({mm; ss} as goal) -> + let s_ls = SH.LsS.find loc ss in + let m_ls = SH.LsS.find loc mm in + assert(true$> + L.printf 6 "chs_lss match m_ls:@[ %a@ |- %a@]" + Ls.fmt m_ls Ls.fmt s_ls ); + (* sub_ls_ls is not complete if m_ls is longer than s_ls *) + sub_ls_ls (Ls.direction s_ls loc) m_ls s_ls goal + | Pure.Disjunctions([]), _ -> + fail_ + | Pure.Disjunctions(_), _ -> + failwith "chs_lss: case split needed" + | Pure.Inconsistent, _ -> + assert( L.warnf "chs_lss: spontaneous inconsistency" ); + commit back_ + ) + | Pure.Disjunctions(_), _ -> + failwith "chs_lss: case split needed" + in + + + let distrib_pt goal = + let {xs; ss} = goal in + try + let s_pt = SH.PtS.choose ss in + assert(true$> L.printf 8 "distrib_pt considering:@ %a" Pt.fmt s_pt ); + let pt_xs = Vars.inter xs (Pt.fv s_pt) in + SH.DjS.kfold ss (fun s_dj next_s_dj -> + assert(true$> L.printf 8 "distrib_pt considering:@ %a" Dj.fmt s_dj ); + if Vars.intersect pt_xs (Dj.fv s_dj) then + let s_dj' = Dj.map (fun dt -> SH.PtS.star [s_pt] dt) s_dj in + let ss = + SH.DjS.add s_dj' (SH.DjS.remove s_dj (SH.PtS.remove s_pt ss)) in + assert(true$> L.printf 3 "applying distrib_pt:@ %a" Pt.fmt s_pt ); + commit (sub {goal with ss}) + else + next_s_dj + ) fail_ + with + Not_found -> fail_ + in + + + let distrib_ls goal = + let {xs; ss} = goal in + try + let s_ls = SH.LsS.choose ss in + assert(true$> L.printf 8 "distrib_ls considering:@ %a" Ls.fmt s_ls ); + let ls_xs = Vars.inter xs (Ls.fv s_ls) in + SH.DjS.kfold ss (fun s_dj next_s_dj -> + assert(true$> L.printf 8 "distrib_ls considering:@ %a" Dj.fmt s_dj ); + if Vars.intersect ls_xs (Dj.fv s_dj) then + let s_dj' = Dj.map (fun dt -> SH.LsS.star [s_ls] dt) s_dj in + let ss = + SH.DjS.add s_dj' (SH.DjS.remove s_dj (SH.LsS.remove s_ls ss)) in + assert(true$> L.printf 6 "distrib_ls:@ %a" Ls.fmt s_ls ); + commit (sub {goal with ss}) + else + next_s_dj + ) fail_ + with + Not_found -> fail_ + in + + + let chs_split_ls goal = + let {mm; ss} = goal in + if SH.DjS.is_empty ss then fail_ else + SH.LsS.kfold mm (fun m_ls (next_m_ls : sub_rule) -> + sub_split_ls m_ls $+ next_m_ls + ) fail__ goal + in + + + let chs_distrib_m goal = + let {mm} = goal in + try + let dj = SH.DjS.choose mm in + assert(true$> L.printf 7 "chs_distrib_m considering:@ %a" Dj.fmt dj ); + commit (sub_distrib_m dj {goal with mm= SH.DjS.remove dj mm}) + with + Not_found -> fail_ + in + + + let chs_distrib_s goal = + let {ss} = goal in + try + let dj = SH.DjS.choose ss in + assert(true$> L.printf 7 "chs_distrib_s considering:@ %a" Dj.fmt dj ); + commit (sub_distrib_s dj {goal with ss= SH.DjS.remove dj ss}) + with + Not_found -> fail_ + in + + + (sub_inconsis_m false $+ sub_inconsis_s false $+ + sub_did $+ sub_emp $+ sub_true $+ + chs_pts find_syntactic_equality $+ + pure_valid ( + sub_inconsis_m true $+ (* sub_inconsis_s true $+ *) + chs_lss find_syntactic_equality $+ +(* chs_pts find_provable_equality $+ *) +(* chs_lss find_provable_equality $+ *) + distrib_pt $+ distrib_ls $+ + chs_distrib_m $+ chs_split_ls $+ chs_distrib_s $+ + sub_emp_lss $+ + (* sub_inconsis_m true $+ *) sub_inconsis_s true + ) + ) + + goal + + + +(*============================================================================ + Entry Points + ============================================================================*) + +(* Backtrack continuations are invalidated by making a new toplevel query. If + we e.g. created new Pure contexts for each query, we could support this. + Deleting such contexts would get tricky. *) +let new_query, is_valid = + let query_count = ref 0 (* counter for toplevel queries *) + in + let new_query kind ((us, mm, xs, ss) as umxs) = + let pm = cxt in + Pure.clear pm ; + let ps = Pure.mk_partition pm in + incr query_count ; +(* assert(true$>( *) + if !query_count = Config.prv_gen_test then + (TestGenProver.gen_query (!query_count, kind, umxs); exit 2) ; + if Config.prv_gen_test < 0 then + (TestGenProver.gen_query (!query_count, kind, umxs)) ; +(* )); *) + let fmt_query = fmt ("( " ^ kind ^ " " ^ (string_of_int !query_count)) in + let goal = {ent= false; us; mm; xs; ss; pm; ps; + nm= mm; ns= ss; cc= SH.emp; pv= SH.emp} + in + (goal, (!query_count, kind, umxs), fmt_query) + in + let is_valid (query,_,_) = + !query_count = query + in + (new_query, is_valid) + + +let subtract mm xs ss : result = + Timer.start subtract_tmr ; + let module ResMset = ImperativeSet.Make(struct + type t = XSH.t + + (* Note: Which comparison should be used? *) + let equal = XSH.equal + let compare = XSH.compare +(* + let equal = XSH.equal_coarse + let compare = XSH.compare_coarse + + (* [r0 = r1] if [q * r0 -||- q * r1] *) + let compare r0 r1 = + let q1 = ss in + let ord = XSH.compare_coarse r0 r1 in + if ord = 0 then ord else + let r0_q1 = XSH.star [SH.exists_intro Vars.empty q1] r0 + and r1_q1 = XSH.star [SH.exists_intro Vars.empty q1] r1 in + let ord = XSH.compare_coarse r0_q1 r1_q1 in + if ord = 0 then ord else + let us = Vars.union (SH.fv mm) (Vars.diff (SH.fv ss) xs) in + let r0_q1_xs, r0_q1 = XSH.exists_bind us r0_q1 in + let r1_q1_xs, r1_q1 = XSH.exists_bind (Vars.union us r0_q1_xs) r1_q1 in + (* guess the common existentials are their own witnesses *) + let ws, xs, ys = Vars.diff_inter_diff r0_q1_xs r1_q1_xs in + let us' = Vars.union us ys in + match + sub {us=us' ; mm= r0_q1; xs; ss= r1_q1} + (fun r bk -> + if XSH.is_empty r then + let us' = Vars.union us ws in + sub {us=us' ; mm= r1_q1; xs; ss= r0_q1} + (fun r bk -> if XSH.is_empty r then Some(r,bk) else bk ()) + (fun _sk bk -> bk ()) + (fun()-> None) + else + bk ()) + (fun _sk bk -> bk ()) + (fun()-> None) + with + | Some(_) -> 0 + | None -> ord + + let equal r0 r1 = 0 = compare r0 r1 +*) + end) + in + let mset = ResMset.create () + in + sub_count := 0; saved_count := 0 + ; + let xs, us_ss = Vars.inter_diff (SH.fv ss) xs in + let us = Vars.union (SH.fv mm) us_ss in + let goal, query, fmt_query = new_query "subtract" (us, mm, xs, ss) in + let indent = L.latch_incf 1 "%a" fmt_query goal in + (try + sub goal + (fun remainder bk -> + if ResMset.mem mset remainder then ( + (* filter out duplicate remainders, proofs need not be unique *) + assert(true$> L.printf 3 "subtract: duplicate remainder" ); + bk () + ) else ( + saved_count := !sub_count ; + assert( not Config.check_prv || ( + (* Note that when points-tos have None contents (as the correct + sort is unknown), valid proofs can fail to be checked if the + contents of the points-to is the unique pointer to an allocated + location. *) + L.printf 8 "self-checking soundness (%i)" !sub_count ; + let s_r = XSH.star [SH.exists_intro Vars.empty ss] remainder in + (* intro and bind xs in order to eliminate them if possible *) + let xs_s_r = XSH.exists_intro xs s_r in + let xs_zs, s_r = XSH.exists_bind us xs_s_r in + let pm = cxt_chk in + Pure.clear pm; + let ps = Pure.mk_partition pm in + let goal = + {goal with pm; xs= xs_zs; ps; ss= s_r; nm= mm; ns= s_r} in + L.shift_verb 5 (fun()-> + ent goal) <> Unknown + || L.warnf "Prover failed to self-check soundness" + )); + sub_count := !saved_count ; + ResMset.add mset remainder ; + let bk() = + Timer.start subtract_tmr ; + if not( is_valid query ) then + failwith "invalid backtrack continuation" ; + sub_count := !saved_count ; + bk() + in + Success(remainder, bk) + )) + (fun _sk bk -> bk()) + (fun()-> Unknown) + with exc -> TestGenProver.gen_query query ; raise exc) + |> + (let rec reset res = + Timer.stop_report subtract_tmr + (if Config.subtract_time >= 0. then Config.subtract_time else subtract_tmr.Timer.max) + (L.printf 0 "subtract %4i (%3i) time:@ %12.6f %12.6f sec" + (fst3 query) !sub_count) ; + match res with + | Unknown -> + L.resetf 1 indent ") subtract: (%i) failed" !sub_count ; + Unknown + | Success(r,k) -> + L.resetf 1 indent ") subtract: (%i) %a" !sub_count XSH.fmt r ; + let k() = + (try k() with exc -> TestGenProver.gen_query query ; raise exc) + |> reset in + Success(r,k) + in reset) + + +let subtract_with_proviso pred mm xs ss = + let rec find_fst k = + match k() with + | Unknown as f -> f + | Success(r,_) as s when pred r -> s + | Success(_,k') -> find_fst k' + in + find_fst (fun()-> subtract mm xs ss) + + +let entails mm xs ss = + Timer.start entails_tmr ; + sub_count := 0 ; + let xs, us_ss = Vars.inter_diff (SH.fv ss) xs in + let us = Vars.union (SH.fv mm) us_ss in + let goal, query, fmt_query = new_query "entails" (us, mm, xs, ss) in + L.incf 1 "%a" fmt_query goal ; + (try + match + ent {goal with ent=true} +(* Version that only tries ent if sub first succeeds: + sub goal + (fun rr bk -> + if XSH.is_empty rr then + Success(rr,bk) + else ( + Pure.clear pm ; + ent {goal with ent=true; ps = Pure.mk_partition pm} + )) + (fun _sk bk -> bk()) + (fun()-> + assert ( + Pure.clear pm ; + ent {goal with ent=true; ps= Pure.mk_partition pm} = Unknown + ) ; + Unknown) *) + with + | Success(rr,_) -> Some(rr) + | Unknown -> None + with exc -> TestGenProver.gen_query query ; raise exc) + &> fun r -> + Timer.stop_report entails_tmr + (if Config.entails_time >= 0. then Config.entails_time else entails_tmr.Timer.max) + (L.printf 0 "entails %4i (%3i) time:@ %12.6f %12.6f sec" + (fst3 query) !sub_count) ; + let sub_count = !sub_count in +(* assert ( *) +(* (* check subtraction is at least as strong as entailment *) *) +(* r = None || *) +(* ( Pure.clear goal.pm ; *) +(* sub {goal with ps= Pure.mk_partition goal.pm} *) +(* (fun rr bk -> Success(rr,bk)) (fun _sk bk -> bk()) (fun()-> Unknown) *) +(* <> Unknown ) *) +(* ) ; *) + L.decf 1 ") entails: (%i) %a" sub_count (Option.fmt "failed" XSH.fmt) r + + +let entailsx p q = + let xs, p' = XSH.exists_bind (XSH.fv q) p in + let ys, q' = XSH.exists_bind (SH.fv p') q in + match entails p' ys q' with + | Some(r) -> Some(XSH.exists_intro (Vars.union xs ys) r) + | None -> None + + +let inconsistent sh = + let pm = cxt in + Pure.clear pm; + assert( + let us = SH.fv sh in + let xs = Vars.empty in + let goal, _, fmt_query = new_query "inconsistent" (us, sh, xs, SH.ff) in + let goal = {goal with ent= false} in + L.incf 2 "%a" fmt_query goal ; + true + ); + let pm = Pure.extend pm in + let _, c, d = SH.pure_consequences sh in + Pure.conjoin pm (E.mkAnd [|c; d|]) ; + let inconsis = Pure.inconsistent inconsistent_tmr pm in + assert( + L.decf 2 ") inconsistent: %B" inconsis ; + true + ); + inconsis + + +let inconsistentx xsh = + let _, sh = XSH.exists_bind Vars.empty xsh in + inconsistent sh + + +(*============================================================================ + Debugging Wrappers + ============================================================================*) + +let subtract_count mm xs ss = + let count = ref 0 in + let rec drain (res : result) = + match res with + | Success(_,k) -> incr count; drain (k()) + | Unknown -> !count in + drain (subtract mm xs ss) diff --git a/src/Prover.mli b/src/Prover.mli new file mode 100644 index 0000000..c5502c9 --- /dev/null +++ b/src/Prover.mli @@ -0,0 +1,45 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Theorem prover for subtraction and entailment of symbolic heaps *) + +open Variable +open SymbolicHeap + + +val subtract_tmr : Timer.t +val entails_tmr : Timer.t +val inconsistent_tmr : Timer.t +val ent_pure_tmr : Timer.t +val sub_inconsis_m_tmr : Timer.t +val sub_inconsis_s_tmr : Timer.t +val pure_normalize_tmr : Timer.t +val sh_normalize_tmr : Timer.t + + +(*============================================================================ + Prover + ============================================================================*) + +type result = Unknown | Success of XSH.t * (unit -> result) + +val subtract : SH.t -> Vars.t -> SH.t -> result + +val subtract_with_proviso : + (XSH.t -> bool) -> SH.t -> Vars.t -> SH.t -> result + +val entails : SH.t -> Vars.t -> SH.t -> XSH.t option +val entailsx : XSH.t -> XSH.t -> XSH.t option + +(** [inconsistent sh] holds only if [sh] is inconsistent, and may not hold + even for logically inconsistent formulae. *) +val inconsistent : SH.t -> bool + +val inconsistentx : XSH.t -> bool + + + +(*============================================================================ + Debugging Wrappers + ============================================================================*) + +val subtract_count : SH.t -> Vars.t -> SH.t -> int diff --git a/src/Pure.ml b/src/Pure.ml new file mode 100644 index 0000000..9476f44 --- /dev/null +++ b/src/Pure.ml @@ -0,0 +1,1208 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Pure formulas and theorem prover *) + +open Library + +module HC = HashCons +open Type +open Variable +open Expression +module E = Exp +module S = Substitution + +module L = (val Log.std Config.vPure : Log.LOG) + + + +(* Timing =================================================================== *) + +let z3_assert_tmr = Timer.create "Z3.assert" +let z3_push_tmr = Timer.create "Z3.push" +let z3_pop_tmr = Timer.create "Z3.pop" +let z3_check_tmr = Timer.create "Z3.check" +let z3_check_assumptions_tmr = Timer.create "Z3.check_assumptions" +let z3_eval_tmr = Timer.create "Z3.eval" +let z3_get_implied_equalities_tmr = Timer.create "Z3.get_implied_equalities" +let get_implied_equalities_tmr = Timer.create "Pure.get_implied_equalities" +let find_provable_equality_tmr = Timer.create "Pure.find_provable_equality" +let conjoin_tmr = Timer.create "Pure.conjoin" +let inconsistent_tmr = Timer.create "Pure.inconsistent" +let implies_tmr = Timer.create "Pure.impliesx" + + +(* Formatting =============================================================== *) + +let fmt_xs = Vars.fmt_embrace "@[? " " .@]@ " + + +(* Initialization =========================================================== *) + +(* let gie_log = *) +(* open_out *) +(* (Config.testname *) +(* ^".gie" *) +(* ^(string_of_int Config.gie) *) +(* ^(if Config.gie_incremental then "1" else "0") *) +(* ^(if Config.gie_weak then "1" else "0") *) +(* ^".dat" *) +(* ) *) + +let _ = + (* Enable warnings and logging *) + Z3.toggle_warning_messages (!Config.vZ3 > 0) ; + if Config.z3_log then + let logname = Config.testname ^ ".z3.log" in + ignore( Z3.open_log logname ) + + + +(*============================================================================ + Extended Z3 context + ============================================================================*) + +type xcontext = { + mutable z: Z3.context; (* backing Z3.context state *) + mutable s: Z3.solver; + mutable i_sort: Z3.sort; (* integer sort *) + mutable v_sort: Z3.sort; (* value sort *) + mutable v_ctor: Z3.func_decl; (* value constructor *) + mutable v_dtors: Z3.func_decl array; (* value destructors *) + mutable b_sort: Z3.sort; (* boolean sort *) + mutable t_sort: Z3.sort; (* type sort *) + mutable allocd: Z3.func_decl; (* allocd predicate *) + mutable zero: Z3.ast; (* cached 0 *) + mutable one: Z3.ast; (* cached 1 *) + mutable mone: Z3.ast; (* cached -1 *) + (* for debugging / test generation: *) + mutable clear_count: int; (* number of 'clear' calls *) + (* for the weak/uninterpreted encoding *) + mutable p_sort: Z3.sort; (* pointer sort *) + mutable u_sort: Z3.sort; (* uninterpreted integer sort *) +} + +type t = { + a: Z3.ast list; (* address into... *) + c: xcontext; (* context tree *) +} + +type partition = Z3.ast + + +let assumptions x parts = + List.rev_append parts x.a + +let assertions ({c={z= ctx; s= slv}} as x) parts = + let v = Z3.solver_get_assertions ctx slv in + let n = Z3.ast_vector_size ctx v in + let rec loop i asserts = + if i < n then + loop (i+1) (Z3.ast_vector_get ctx v i :: asserts) + else + asserts + in + loop 0 (assumptions x parts) + + + + +(*============================================================================ + Extended Z3 interface + ============================================================================*) + +module Z3 = struct + include Z3 + + (* Wrappers to establish preconditions ==================================== *) + + let mk_and x = function + | [||] -> mk_true x + | [|b|] -> b + | bs -> mk_and x bs + + let mk_or x = function + | [||] -> mk_false x + | [|b|] -> b + | bs -> mk_or x bs + + let mk_add ({c={z= ctx}} as x) = function + | [||] -> x.c.zero + | [|e|] -> e + | es -> mk_add ctx es + + let mk_mul ({c={z= ctx}} as x) = function + | [||] -> x.c.one + | [|e|] -> e + | es -> mk_mul ctx es + + let mk_sub ({c={z= ctx}} as x) = function + | [||] -> x.c.zero + | [|e|] -> e + | es -> mk_sub ctx es + + let mk_distinct x = function + | [||] | [|_|] -> mk_true x +(* | es -> mk_distinct x es *) + (* Note: Z3 sometimes fails to eliminate quantified vars in distinct's? *) + | es -> + if Config.z3_distinct then + mk_distinct x es + else + mk_and x (Array.of_list + (List.fold_pairs (fun e f dqs -> + mk_not x (mk_eq x e f) :: dqs + ) (Array.to_list es) [])) + + + (* Formatting ============================================================= *) + + let fmt_lbool ff b = + Format.fprintf ff "%s" (match b with L_TRUE -> "true" | L_FALSE -> "false" | L_UNDEF -> "undef") + + let fmt_ast x ff p = Format.fprintf ff "%s" (ast_to_string x p) + + let fmt_cnstrs ?(parts=[]) ff ({c={z= ctx}} as x) = + List.fmt "@\n" (fmt_ast ctx) ff (assertions x parts) + + + (* Test generation and Error reporting ==================================== *) + + let test_count = ref 0 + + let gen_test_ ?(parts=[]) ({c={z= ctx}} as x) f trailer = + let testname = Config.testname ^ "_" ^ (string_of_int !test_count) in + incr test_count ; + let cnstr = assertions x parts in + let str = benchmark_to_smtlib_string ctx testname "" "unknown" "" (Array.of_list cnstr) f in + let chan = open_out (testname ^ ".smt") in + output_string chan str ; + trailer chan ; + close_out chan + + let _gen_test ?(parts=[]) x f = + (* let f = simplify ctx f in *) + gen_test_ ~parts x f (fun _ -> ()) + + let _gen_test_smtc fn ?(parts=[]) ({c={z= ctx}} as x) es = + if Config.z3_print_mode <> "smt2" then + L.printf 0 "%s tests only supported for smt2 z3_print_mode" fn + else + (* add trivial equalities to ensure every variable in es is declared *) + let f = mk_and ctx (Array.map (fun e -> mk_eq ctx e e) es) in + gen_test_ ~parts x f (fun chan -> + output_string chan "(" ; + output_string chan fn ; + Array.iter (fun e -> + output_string chan " " ; + output_string chan (ast_to_string ctx e) + ) es ; + output_string chan ")\n" ; + ) + + let _report_failure _expecting_sat {c={z= ctx; s= slv}} _ps = + assert(true$> + let failure = solver_get_reason_unknown ctx slv in + match failure with + | "" -> () +(* | QUANTIFIERS when expecting_sat -> () *) + | _ -> + (* gen_test x ((* simplify ctx *) (mk_and ctx _ps)) ; *) + L.printf 1 "WARNING: Z3 search failed (%s)" failure + ) + + let _report_model {c={z= ctx; s= slv}} = + assert( + not Config.z3_model || + match solver_check ctx slv with + | L_TRUE -> + let m = solver_get_model ctx slv in + L.warnf "model:@\n%s" (model_to_string ctx m) + | _ -> + true + ) + + + (* Timing ================================================================= *) + + let solver_assert ctx slv f = +(* L.printf 0 "ASSERT:@\n%a" (fmt_ast ctx) f ; *) + Timer.start z3_assert_tmr ; (fun _ -> Timer.stop z3_assert_tmr) <& + solver_assert ctx slv f + + let solver_push ctx slv = +(* L.incf 0 "( PUSH: ctx#%i" x.c.id ; *) + Timer.start z3_push_tmr ; (fun _ -> Timer.stop z3_push_tmr) <& + solver_push ctx slv + + let solver_pop ctx slv n = +(* L.decf 0 ") POP: ctx#%i %i" x.c.id n ; *) + Timer.start z3_pop_tmr ; (fun _ -> Timer.stop z3_pop_tmr) <& + solver_pop ctx slv n + + let solver_check ctx slv = + Timer.start z3_check_tmr ; (fun _ -> Timer.stop z3_check_tmr) <& + solver_check ctx slv + + let solver_check_assumptions ctx slv a = + Timer.start z3_check_assumptions_tmr ; + (fun _ -> + Timer.stop_report z3_check_assumptions_tmr + (if Config.check_assumptions_time >= 0. + then Config.check_assumptions_time + else z3_check_assumptions_tmr.Timer.max) + (L.printf 0 "check_assumptions time: %12.6f %12.6f sec")) + <& + solver_check_assumptions ctx slv a + + let model_eval ctx slv m a = + Timer.start z3_eval_tmr ; (fun _ -> Timer.stop z3_eval_tmr) <& + model_eval ctx slv m a + + let get_implied_equalities ctx slv a = + Timer.start z3_get_implied_equalities_tmr ; (fun _ -> Timer.stop z3_get_implied_equalities_tmr) <& + get_implied_equalities ctx slv a + + + (* Implied Equalities ===================================================== *) + + let get_implied_equalities_naive ctx slv terms = + let n = Array.length terms in + let rep = Array.init n (fun i -> i) in + match solver_check ctx slv with + | L_TRUE -> + for i = 0 to n-1 do + for j = i+1 to n-1 do + if is_eq_sort ctx (get_sort ctx terms.(i)) (get_sort ctx terms.(j)) then ( + solver_push ctx slv ; + solver_assert ctx slv (mk_not ctx (mk_eq ctx terms.(i) terms.(j))) ; + if solver_check ctx slv = L_FALSE then rep.(j) <- rep.(i) ; + solver_pop ctx slv 1 ; + ) + done + done ; + (L_TRUE, rep) + | res -> + (res, rep) + + + exception Unknown + + (* asserts constraints, assumes client wraps call in push/pop *) + let get_implied_equalities_refine ctx slv terms = + assert( terms <> [||] ) + ; + (* temporary table to forward values to the terms that have been chosen as their representatives *) + let val_to_rep = PolyHMap.create 128 + in + let new_rep ctx m terms current_partition i = + match model_eval ctx m terms.(i) false with + | Some(v) -> + (try + PolyHMap.find val_to_rep (current_partition, v) + with Not_found -> + PolyHMap.add val_to_rep (current_partition, v) terms.(i) ; + terms.(i) + ) + | None -> + failwith "eval failed" + in + try + (* check satisfiability *) + match solver_check ctx slv with + | L_TRUE -> + let m = solver_get_model ctx slv + in + let n = Array.length terms + in + (* initialize representative array with equalities in model *) + let rep = Array.init n (fun i -> new_rep ctx m terms 0 i) + in + PolyHMap.clear val_to_rep + ; + (* cache bool sort and true value *) + let bool_sort = mk_bool_sort ctx + and tt = mk_true ctx + in + (* initialize proposition heap *) + let ph = Array.init (2*n-1) (fun _ -> mk_fresh_const ctx "phi" bool_sort) + in + (* assert that each internal node holds iff one of its children does *) + let assert_internal i = + let l = 2*i+1 in + let r = l+1 in + solver_assert ctx slv (mk_iff ctx ph.(i) (mk_or ctx [|ph.(l); ph.(r)|])) + in + for i = 0 to n-2 do assert_internal i done + ; + (* assert that each leaf node holds iff the corresponding term is not equal to its representative *) + let assert_leaf i = + let j = i - (n-1) in + solver_assert ctx slv (mk_iff ctx ph.(i) (mk_not ctx (mk_eq ctx terms.(j) rep.(j)))) + in + for i = n-1 to 2*n-2 do assert_leaf i done + ; + (* iteratively refine partition into equivalence classes determined by rep *) + let rec loop () = + (* assert that the partition is too coarse *) + solver_assert ctx slv ph.(0) ; + match solver_check ctx slv with + | L_TRUE -> + let m = solver_get_model ctx slv + in + (* at least one equation has been broken, refine partition based on new model *) + let rec update i = + match model_eval ctx m ph.(i) false with + | Some(b) when is_eq_ast ctx tt b -> + (* some equality under i was broken *) + ph.(i) <- mk_fresh_const ctx "phi" bool_sort + ; + if i < n-1 then ( + (* i is internal so consider its children *) + let l = 2*i+1 in + let r = l+1 in + update l ; + update r ; + assert_internal i + ) else ( + (* i is a leaf so refine partition *) + let j = i - (n-1) in + rep.(j) <- new_rep ctx m terms (get_ast_id ctx rep.(j)) j ; + assert_leaf i + ) + | Some(_) -> + (* no equality under i was broken *) + () + | None -> + failwith "eval failed" + in + update 0 + ; + PolyHMap.clear val_to_rep + ; + loop () + | L_FALSE -> + (* no more equations can be broken, all equalities in rep are implied *) + (L_TRUE, Array.map (fun e -> get_ast_id ctx e) rep) + | L_UNDEF -> + raise Unknown + in + loop () + | L_FALSE -> + (* context is inconsistent, equate all terms of the same sort *) + (L_FALSE, Array.map (fun e -> get_ast_id ctx (get_sort ctx e :>ast)) terms) + | L_UNDEF -> + raise Unknown + with Unknown -> + (* do not equate any terms *) + (L_UNDEF, Array.mapi (fun i _ -> i) terms) + +end + + + +(*============================================================================ + Translation from Exp.t to Z3.ast + ============================================================================*) + +(* This translation code assumes that the Z3 ast constructors return + (logically) equivalent results for equal arguments, except for + Z3.mk_fresh_*. *) + +let is_val ({c={z= ctx}} as x) e = Z3.is_eq_sort ctx x.c.v_sort (Z3.get_sort ctx e) + +let mk_v ({c={z= ctx}} as x) (b,y,i) = Z3.mk_app ctx x.c.v_ctor [|b;y;i|] + +let is_val_app ({c={z= ctx}} as x) v = + Z3.get_ast_kind ctx v = Z3.APP_AST + && Z3.is_eq_func_decl ctx (Z3.get_app_decl ctx (Z3.to_app ctx v)) x.c.v_ctor + +let get_v_loc ({c={z= ctx}} as x) v = + if is_val_app x v then + Z3.get_app_arg ctx (Z3.to_app ctx v) 0 + else + Z3.mk_app ctx x.c.v_dtors.(0) [|v|] + +let get_v_off ({c={z= ctx}} as x) v = + if is_val_app x v then + Z3.get_app_arg ctx (Z3.to_app ctx v) 1 + else + Z3.mk_app ctx x.c.v_dtors.(1) [|v|] + +let get_v_bit ({c={z= ctx}} as x) v = + if is_val_app x v then + Z3.get_app_arg ctx (Z3.to_app ctx v) 2 + else + Z3.mk_app ctx x.c.v_dtors.(2) [|v|] + +let get_val x e = + if is_val x e then (get_v_loc x e, get_v_off x e, get_v_bit x e) else (e, x.c.zero, x.c.mone) + +(* let get_int x e = *) +(* if is_val x e then *) +(* let e_l = get_v_loc x e and e_o = get_v_off x e in *) +(* Z3.mk_add x [|e_l; e_o|] *) +(* else *) +(* e *) + + +let mk_var ({c={z= ctx}} as x) v = + Z3.mk_const ctx (Z3.mk_int_symbol ctx (Var.id v)) + (match Var.sort v with + | Var.PointerSort -> x.c.v_sort + | Var.OffsetSort -> x.c.v_sort + | Var.IntegerSort -> x.c.i_sort + | Var.BooleanSort -> x.c.b_sort) + +let mk_vars ({c={z= ctx}} as x) vs = + Array.of_list (Vars.fold (fun v vs' -> Z3.to_app ctx (mk_var x v) :: vs') vs []) + +let mk_exists ({c={z= ctx}} as x) vs q = + if Vars.is_empty vs then q else + Z3.mk_exists_const ctx Config.quant_weight (mk_vars x vs) [||] q + + +let rec to_z3 x d = + to_z3_ x (E.desc d) + +and to_z3_ ({c={z= ctx}} as x) d = try + match d with + + | E.Var(v) -> mk_var x v + + | E.App({HC.desc=E.App({HC.desc=E.Idx},f)},e) -> + let e_l, e_o, e_b = get_val x (to_z3 x e) in + let f' = to_z3 x f in + mk_v x (e_l, Z3.mk_add x [|e_o; f'|], e_b) + + | E.App({HC.desc=E.Idx},e) -> + to_z3 x (E.mkIdx E.nil e) + + | E.Idx -> + to_z3 x (E.mkIdx E.nil E.zero) + + | E.App(f,e) -> + let mk_o, f = + match E.desc f with + | E.Add(f) -> (Z3.mk_add, f) + | E.Sub(f) -> (Z3.mk_sub, f) + | _ -> failwithf "to_z3: unexpected operand: %a" E.fmt f + and e_l, e_o, _ = get_val x (to_z3 x e) in + let f_o, f_b = Fld.off f in + let f_o' = Z3.mk_int ctx f_o x.c.i_sort in + let f_b' = Option.option x.c.mone (fun b -> Z3.mk_int ctx b x.c.i_sort) f_b in + mk_v x (e_l, mk_o x [|e_o; f_o'|], f_b') + + | E.Nil -> Z3.mk_int ctx 0 x.c.i_sort + + | E.Add(f) -> to_z3 x (E.mkAdd (E.mkBas (Fld.typ f)) f) + + | E.Sub(f) -> to_z3 x (E.mkSub (E.mkBas (Fld.typ f)) f) + + | E.Bas(_) -> Z3.mk_int ctx 0 x.c.i_sort + + | E.Eq(e,f) -> + let e' = to_z3 x e in + let f' = to_z3 x f in + let e_l, e_o, e_b = get_val x e' + and f_l, f_o, f_b = get_val x f' in + Z3.mk_and ctx [|Z3.mk_eq ctx e_l f_l; Z3.mk_eq ctx e_o f_o; Z3.mk_eq ctx e_b f_b|] + + | E.Num(n) -> Z3.mk_int64 ctx n x.c.i_sort + + | E.Str(s) -> Z3.mk_const ctx (Z3.mk_string_symbol ctx ("\""^s^"\"")) x.c.i_sort + + | E.Op1(E.Allocd,e) -> + let e' = to_z3_ x e in + if is_val x e' then + Z3.mk_and ctx [|Z3.mk_app ctx x.c.allocd [|e'|]; + Z3.mk_gt ctx (get_v_loc x e') x.c.zero; + Z3.mk_ge ctx (get_v_off x e') x.c.zero; + Z3.mk_ge ctx (get_v_bit x e') x.c.mone|] + else + Z3.mk_and ctx [|Z3.mk_app ctx x.c.allocd [|mk_v x (e', x.c.zero, x.c.mone)|]; + Z3.mk_gt ctx e' x.c.zero|] + + | E.Op1(E.Not,b) -> Z3.mk_not ctx (to_z3_ x b) + + | E.Op1(E.ZMin,e) -> + let e' = to_z3_ x e in + assert( not (is_val x e') ); + Z3.mk_unary_minus ctx e' + + | E.Op2(o,e,f) -> + let mk_o = + match o with + | E.ZDiv -> Z3.mk_div + | E.ZRem -> Z3.mk_rem + | E.ZMod -> Z3.mk_mod + | E.ZLt -> Z3.mk_lt + | E.ZLe -> Z3.mk_le + | E.ZGt -> Z3.mk_gt + | E.ZGe -> Z3.mk_ge in + let e' = to_z3_ x e in + let f' = to_z3_ x f in +(* assert( not (is_val x e') ); *) +(* assert( not (is_val x f') ); *) + (* Note: Once integers and pointers are correctly distinguished, use the + preceding assertions and remove all following cases but the last. *) + if is_val x e' then + if is_val x f' then + Z3.mk_and ctx [|mk_o ctx (get_v_loc x e') (get_v_loc x f'); + Z3.mk_eq ctx (get_v_off x e') x.c.zero; + Z3.mk_eq ctx (get_v_off x f') x.c.zero; + Z3.mk_eq ctx (get_v_bit x e') x.c.mone; + Z3.mk_eq ctx (get_v_bit x f') x.c.mone|] + else + Z3.mk_and ctx [|mk_o ctx (get_v_loc x e') f'; + Z3.mk_eq ctx (get_v_off x e') x.c.zero; + Z3.mk_eq ctx (get_v_bit x e') x.c.mone|] + else + if is_val x f' then + Z3.mk_and ctx [|mk_o ctx e' (get_v_loc x f'); + Z3.mk_eq ctx (get_v_off x f') x.c.zero; + Z3.mk_eq ctx (get_v_bit x f') x.c.mone|] + else + mk_o ctx e' f' + + | E.Op3(E.Ite,g,t,e) -> + let g' = to_z3_ x g in + let t' = to_z3_ x t in + let e' = to_z3_ x e in + (match is_val x t', is_val x e' with + | true, false -> Z3.mk_ite ctx g' t' (mk_v x (e', x.c.zero, x.c.mone)) + | false, true -> Z3.mk_ite ctx g' (mk_v x (t', x.c.zero, x.c.mone)) e' + | _ -> Z3.mk_ite ctx g' t' e' + ) + | E.OpN(E.Distinct,el) -> + let el' = + Array.map (fun e -> + let e' = to_z3_ x e in + if is_val x e' then e' else mk_v x (e', x.c.zero, x.c.mone) + ) el + in Z3.mk_distinct ctx el' + + | E.OpN(E.And,cn) -> Z3.mk_and ctx (Array.map (to_z3_ x) cn) + + | E.OpN(E.Or,dn) -> Z3.mk_or ctx (Array.map (to_z3_ x) dn) + + | E.OpN((E.ZAdd | E.ZMul) as o, el) -> + let mk_o = match o with E.ZAdd -> Z3.mk_add | E.ZMul -> Z3.mk_mul | _ -> assert false in + let el' = + Array.map (fun e -> + let e' = to_z3_ x e in + assert( not (is_val x e') || failwithf "to_z3 unexpected Value: %a" E.fmt (E.name e) ); + e' + ) el + in mk_o x el' + + | E.OpN(E.UFun(s),el) -> + let el' = + Array.map (fun e -> + let e' = to_z3_ x e in + assert( not (is_val x e') ); + e' + ) el in + let arg_sorts = Array.make (Array.length el') x.c.i_sort in + Z3.mk_app ctx (Z3.mk_func_decl ctx (Z3.mk_string_symbol ctx s) arg_sorts x.c.i_sort) el' + + with exc -> L.printf 0 "to_z3:@ %a" E.fmt (E.name d); raise exc + + +let to_z3 x e = + let e' = to_z3 x e in + match E.sort_of e with + | (Var.PointerSort | Var.IntegerSort | Var.OffsetSort) when not (is_val x e') -> mk_v x (e', x.c.zero, x.c.mone) + | _ -> e' + + + +(*============================================================================ + Contexts, aka Imperative Formulas + ============================================================================*) + +(* Constructors ============================================================= *) + +let mk_partition {c={z= ctx}} = + Z3.mk_fresh_const ctx "partition" (Z3.mk_bool_sort ctx) + + +let mk () = + let ctx = Z3.mk_context [] + in + let slv = + if Config.pur_eager_qe then + Z3.mk_simple_solver ctx + else + Z3.mk_solver_from_tactic ctx (Z3.tactic_and_then ctx (Z3.mk_tactic ctx "qe") (Z3.mk_tactic ctx "smt")) + in + let i_sort = Z3.mk_int_sort ctx + and b_sort = Z3.mk_bool_sort ctx + in + let v_sort, v_ctor, v_dtors = + Z3.mk_tuple_sort ctx (Z3.mk_string_symbol ctx "Val") + [|Z3.mk_string_symbol ctx "get_loc"; Z3.mk_string_symbol ctx "get_off"; Z3.mk_string_symbol ctx "get_bit"|] + [|i_sort; i_sort; i_sort|] + in + let t_sort = Z3.mk_uninterpreted_sort ctx (Z3.mk_string_symbol ctx "Typ") + in + let allocd = Z3.mk_func_decl ctx (Z3.mk_string_symbol ctx "allocd") [|v_sort|] b_sort + and zero = Z3.mk_int ctx 0 i_sort + and one = Z3.mk_int ctx 1 i_sort + and mone = Z3.mk_int ctx (-1) i_sort + in + let p_sort = Z3.mk_uninterpreted_sort ctx (Z3.mk_string_symbol ctx "Ptr") + and u_sort = Z3.mk_uninterpreted_sort ctx (Z3.mk_string_symbol ctx "Int") + in + let params = Z3.mk_params ctx in + Z3.params_set_bool ctx params (Z3.mk_string_symbol ctx "model") true ; + if Config.z3_timeout > 0 then + Z3.params_set_uint ctx params (Z3.mk_string_symbol ctx "timeout") Config.z3_timeout ; + Z3.params_set_uint ctx params (Z3.mk_string_symbol ctx "verbose") (max 0 (!Config.vZ3 - 1)) ; + Z3.params_set_bool ctx params (Z3.mk_string_symbol ctx "unsat_core") true ; + Z3.params_set_uint ctx params (Z3.mk_string_symbol ctx "memory_high_watermark") Config.z3_memout ; + Z3.params_set_uint ctx params (Z3.mk_string_symbol ctx "memory_max_size") Config.z3_memout ; + Z3.params_set_double ctx params (Z3.mk_string_symbol ctx "sat.random_freq") 0. ; + Z3.params_set_bool ctx params (Z3.mk_string_symbol ctx "nlsat.randomize") false ; + Z3.params_set_uint ctx params (Z3.mk_string_symbol ctx "nlsat.seed") 0 ; + Z3.params_set_bool ctx params (Z3.mk_string_symbol ctx "smt.arith.nl") false ; + Z3.params_set_bool ctx params (Z3.mk_string_symbol ctx "smt.ematching") Config.z3_ematching ; + Z3.params_set_uint ctx params (Z3.mk_string_symbol ctx "smt.random_seed") 0 ; + Z3.params_set_uint ctx params (Z3.mk_string_symbol ctx "smt.relevancy") Config.z3_relevancy ; + Z3.solver_set_params ctx slv params ; + (* Set print mode *) + Z3.set_ast_print_mode ctx + (match Config.z3_print_mode with + | "full" -> Z3.PRINT_SMTLIB_FULL + | "low" -> Z3.PRINT_LOW_LEVEL + | "smt" -> Z3.PRINT_SMTLIB_COMPLIANT + | "smt2" -> Z3.PRINT_SMTLIB2_COMPLIANT + | s -> failwithf "unrecognized print mode: " s + ); + { a= [] + ; c={ + z= ctx; s= slv; + i_sort; v_sort; v_ctor; v_dtors; b_sort; + t_sort; allocd; zero; one; mone; + clear_count= 0; + p_sort; u_sort; + }} + + +let clear ({c={z= ctx; s= slv}} as x) = + x.c.clear_count <- x.c.clear_count + 1 ; + if x.c.clear_count <> Config.reset_freq then ( + Z3.solver_reset ctx slv + ) else ( + let y = mk () in + x.c.z <- y.c.z ; + x.c.s <- y.c.s ; + x.c.i_sort <- y.c.i_sort ; + x.c.v_sort <- y.c.v_sort ; + x.c.v_ctor <- y.c.v_ctor ; + x.c.v_dtors <- y.c.v_dtors ; + x.c.b_sort <- y.c.b_sort ; + x.c.t_sort <- y.c.t_sort ; + x.c.allocd <- y.c.allocd ; + x.c.zero <- y.c.zero ; + x.c.one <- y.c.one ; + x.c.mone <- y.c.mone ; + x.c.clear_count <- y.c.clear_count ; + x.c.p_sort <- y.c.p_sort ; + x.c.u_sort <- y.c.u_sort ; + ) + + + +let extend ({c={z= ctx}} as x) = + {x with a= (Z3.mk_fresh_const ctx "hyp" (Z3.mk_bool_sort ctx)) :: x.a} + + + +let conjoin ?(parts=[]) ({c={z= ctx; s= slv}} as x) bex = + assert(true$> L.printf 10 "Pure.conjoin: %a" E.fmt bex ); + Timer.start conjoin_tmr ; (fun _ -> Timer.stop conjoin_tmr) + <& + let cnstr = to_z3 x bex in +(* L.printf 0 "Pure.conjoin: %a" (Z3.fmt_ast ctx) cnstr ; *) + let assumptions = assumptions x parts in + let imp_cnstr = + if assumptions = [] then cnstr else + Z3.mk_implies ctx (Z3.mk_and ctx (Array.of_list assumptions)) cnstr in + Z3.solver_assert ctx slv imp_cnstr + + + +(*============================================================================ + Logical Queries + ============================================================================*) + + +let report_eval ({c={z= ctx; s= slv}} as x) assumptions bex is_unsat = assert(true$> + if not Config.z3_model then () else + match is_unsat with + | Some(false) -> + (match Z3.solver_check_assumptions ctx slv assumptions with + | Z3.L_TRUE -> + let m = Z3.solver_get_model ctx slv in + L.printf 30 "model:@\n%s" (Z3.model_to_string ctx m) ; + (* keep only subexps that evaluate to false *) + let bex_ff = + let ff = Z3.mk_false ctx in + E.map (fun b -> + if not (E.is_boolean b) then b + else match Z3.model_eval ctx m (to_z3 x b) false with + | Some(b') when Z3.is_eq_ast ctx ff (Z3.simplify ctx b') -> + b + | _ -> + E.tt + ) bex + in + (* keep only subexps that evaluate to non-true *) + let bex_tt = + let tt = Z3.mk_true ctx in + E.map (fun b -> + if not (E.is_boolean b) then b + else match Z3.model_eval ctx m (to_z3 x b) false with + | Some(b') when Z3.is_eq_ast ctx tt (Z3.simplify ctx b') -> + E.tt + | _ -> + b + ) bex + in + let es = + E.fold (fun e es -> + match E.desc e with + | E.Num _ -> es + | E.Op1 _ -> Exps.add e es + | E.Var _ when E.is_boolean e -> Exps.add e es + | _ when not (E.is_boolean e) -> Exps.add e es + | _ -> es + ) bex Exps.empty in + let es' = + Exps.fold (fun e es' -> + (* Note: once types are correct, remove this exception handling *) + try match Z3.model_eval ctx m (to_z3 x e) false with + | Some(e') -> (e, Z3.simplify ctx e') :: es' + | _ -> es' + with Z3.Error _ -> es' + ) es [] in + L.printf 3 "bex_ff: %a" E.fmt bex_ff ; + L.printf 4 "bex_tt: %a@\n@[%a@]" E.fmt bex_tt + (List.fmt "@\n" (fun ff (e,e') -> Format.fprintf ff "%a = @[%a@]" E.fmt e (Z3.fmt_ast ctx) e')) es' + | _ -> () + ) + | Some(true) -> + (match Z3.solver_check_assumptions ctx slv assumptions with + | Z3.L_FALSE -> + let core_vec = Z3.solver_get_unsat_core ctx slv in + let core = + Array.init (Z3.ast_vector_size ctx core_vec) (fun i -> Z3.ast_vector_get ctx core_vec i) in + L.printf 3 "core: %a" + (List.fmt " " (fun ff e -> Z3.fmt_ast ctx ff e)) + (Array.to_list core) + | Z3.L_TRUE -> + L.printf 0 "spontaneous consistency" + | Z3.L_UNDEF -> + L.printf 0 "report_eval got undef" + ) + | None -> + () +) + + +let inconsistent ?(parts=[]) ({c={z= ctx; s= slv}} as x) = + assert(true$>( + L.incf 1 "( Pure.inconsistent: %i" !Z3.test_count ; + L.printf 10 "assertions:@\n%a" (Z3.fmt_cnstrs ~parts) x ; +(* Z3.gen_test ~parts x (Z3.mk_and ctx (Array.of_list *) +(* (assumptions x parts))) *))) ; + Timer.start inconsistent_tmr ; + (fun a -> + Timer.stop inconsistent_tmr ; assert(true$>( + report_eval x (Array.of_list (assumptions x parts)) E.tt (Some(a)) ; + L.decf 1 ") Pure.inconsistent: %B" a))) + <& + ((Z3.solver_check_assumptions ctx slv (Array.of_list (assumptions x parts))) = Z3.L_FALSE) + + +let impliesx ?(parts=[]) ({c={z= ctx; s= slv}} as x) (xs,bex) = + if E.equal bex E.ff then + Some(inconsistent ~parts x) + else if E.equal bex E.tt then + Some(true) + else ( + assert(true$>( + L.incf 1 "( Pure.implies@[x: %i @[%a%a@]@]" !Z3.test_count fmt_xs xs E.fmt bex )); + Timer.start implies_tmr ; + (fun a -> + Timer.stop implies_tmr ; assert(true$>( + L.decf 1 ") Pure.impliesx: %a" (Option.fmt "failed" Format.pp_print_bool) a))) + <& + let concl = Z3.mk_fresh_const ctx "concl" x.c.b_sort in + let not_xs_bex' = Z3.mk_not ctx (mk_exists x xs (to_z3 x bex)) in + let cnstr = Z3.mk_implies ctx concl not_xs_bex' in + if Config.pur_eager_qe then + let qe_tac = Z3.mk_tactic ctx "qe" in + let qe_goal = Z3.mk_goal ctx false false false in + Z3.goal_assert ctx qe_goal cnstr ; + let ar = Z3.tactic_apply ctx qe_tac qe_goal in + Z3.goal_reset ctx qe_goal ; + let n = Z3.apply_result_get_num_subgoals ctx ar in + let rec assert_subgoals i = + if i < n then + let subgoal = Z3.apply_result_get_subgoal ctx ar i in + let formulas = Array.init (Z3.goal_size ctx subgoal) (Z3.goal_formula ctx subgoal) in + Z3.solver_assert ctx slv (Z3.mk_or ctx formulas) ; + assert_subgoals (i+1) + in + assert_subgoals 0 + else + Z3.solver_assert ctx slv cnstr ; + assert(true$>( + L.printf 10 "assertions:@\n%a" (Z3.fmt_cnstrs ~parts) x ; + L.printf 10 "not_xs_bex':@\n%a" (Z3.fmt_ast ctx) + ((* Z3.simplify ctx *) not_xs_bex') )); +(* Z3.gen_test ~parts x (Z3.mk_and ctx (Array.of_list (not_xs_bex' :: assumptions x parts))) ; *) + let assumptions = Array.of_list (concl :: assumptions x parts) in + match Z3.solver_check_assumptions ctx slv assumptions with + | Z3.L_UNDEF -> None + | Z3.L_FALSE -> Some(true) + | Z3.L_TRUE -> Some(false) + &> report_eval x assumptions bex + ) + +let implies ?parts x bex = impliesx ?parts x (Vars.empty, bex) + + + +type find_provable_equality_t = + | Inconsistent + | Equality of Exp.t * Exp.t + | Disjunctions of (Exp.t * Exp.t) list list + + +let find_provable_equality ?(parts=[]) ({c={z= ctx; s= slv}} as x) m_locs s_locs keep = + Timer.start find_provable_equality_tmr ; + (fun _ -> + Timer.stop find_provable_equality_tmr ) + <& + let module AstSet = Set.Make(struct + type t = Z3.ast + let compare e f = Pervasives.compare (Z3.get_ast_id ctx e) (Z3.get_ast_id ctx f) + let equal e f = Z3.is_eq_ast ctx e f + end) in + + let eqs = + Exps.fold (fun m_loc eqs -> + Exps.fold (fun s_loc eqs -> + if keep m_loc s_loc then (m_loc, s_loc) :: eqs else eqs + ) s_locs eqs + ) m_locs [] in + + (* check if there are any equalities to try *) + if eqs = [] then + Disjunctions([]) + else + + (* check if all equalities are vacuously implied *) + if Z3.solver_check_assumptions ctx slv (Array.of_list (assumptions x parts)) = Z3.L_FALSE then + Inconsistent + else let()=()in + + (* Note: remove this push/pop, add assumptions to others and adjust *) + Z3.solver_push ctx slv ; + + List.iter (fun f -> Z3.solver_assert ctx slv f) (assumptions x parts) ; + + let dq_name_to_locs = PolyHMap.create 127 in (* Note: tune *) + + (* assert conditional disequalities *) + let dq_names = + List.fold (fun (m_loc, s_loc) dq_names -> + let m_loc' = to_z3 x m_loc in + let s_loc' = to_z3 x s_loc in + (* generate a literal 'name' for [m_loc != s_loc] *) + let str = if !Config.vPure <= 1 then "dq_name" else Format.asprintf "%a" E.fmt (E.mkDq m_loc s_loc) in + let dq_name = Z3.mk_fresh_const ctx str x.c.b_sort in + (* assert [!dq_name \/ m_loc != s_loc] so that assuming [dq_name] + forces [m_loc != s_loc] *) + Z3.solver_assert ctx slv + (Z3.mk_implies ctx dq_name + (Z3.mk_not ctx (Z3.mk_eq ctx m_loc' s_loc'))) ; + PolyHMap.add dq_name_to_locs dq_name (m_loc, s_loc) ; + AstSet.add dq_name dq_names + ) eqs AstSet.empty in + + let rec search cores dq_names = +(* L.printf 0 "Pure.search: %a" *) +(* (List.fmt " " (fun ff e -> Z3.fmt_ast ctx ff e)) *) +(* (AstSet.to_list dq_names) ; *) + if AstSet.is_empty dq_names then + Disjunctions(cores) + else + let assumptions = AstSet.to_array dq_names in + if Z3.solver_check_assumptions ctx slv assumptions = Z3.L_FALSE then + let core = Z3.solver_get_unsat_core ctx slv in + let rec fold_range fn i j z = + if i >= j then z else fold_range fn (i+1) j (fn (Z3.ast_vector_get ctx core i) z) + in + (match Z3.ast_vector_size ctx core with + | 1 -> + (* the negated disequality named by core.(0) is implied *) + let m_loc, s_loc = PolyHMap.find dq_name_to_locs (Z3.ast_vector_get ctx core 0) in +(* L.printf 0 "proved: %a = %a" E.fmt m_loc E.fmt s_loc ; *) + Equality(m_loc, s_loc) + | core_len when core_len > 1 -> + (* the disjunction of negated disequalities in core is implied, + perform binary search over core to try to find one that is + implied, if not remove core from dq_names and search again *) +(* L.printf 0 "core: %a" (List.fmt " " (fun ff e -> Z3.fmt_ast ctx ff e)) *) +(* (fold_range List.cons 0 core_len []) ; *) + let m = core_len / 2 in + let subrange0 = fold_range AstSet.add 0 m AstSet.empty in + (match search cores subrange0 with + | Equality _ as res -> res + | _ -> + let subrange1 = fold_range AstSet.add m core_len AstSet.empty in + match search cores subrange1 with + | Equality _ as res -> res + | _ -> + let core' = + fold_range (fun core_i core' -> + PolyHMap.find dq_name_to_locs core_i :: core' + ) 0 core_len [] in + let cores = core' :: cores in + search cores (fold_range AstSet.remove 0 core_len dq_names) + ) + | core_len -> failwithf "Z3 bug: unsat core length %i < 1" core_len + ) + else +(* L.printf 0 "failed" ; *) + Disjunctions(cores) + in + let res = search [] dq_names in + Z3.solver_pop ctx slv 1 ; + res + + + + +let rec to_z3_weak x d = + if not Config.gie_weak then to_z3 x d else + to_z3_weak_ x (E.desc d) + +and to_z3_weak_ ({c={z= ctx}} as x) d = try + match d with + + | E.Var(v) -> + Z3.mk_const ctx (Z3.mk_int_symbol ctx (Var.id v)) + (match Var.sort v with + | Var.PointerSort -> x.c.p_sort + | Var.OffsetSort -> x.c.p_sort + | Var.IntegerSort -> x.c.u_sort + | Var.BooleanSort -> x.c.b_sort) + + | E.App({HC.desc= E.Add(f)},e) -> + let sym = Z3.mk_string_symbol ctx ("fld_const_"^(Fld.name f)) in + let f' = Z3.mk_func_decl ctx sym [|x.c.p_sort|] x.c.p_sort in + Z3.mk_app ctx f' [|to_z3_weak x e|] + + | E.App({HC.desc= E.Sub(f)},e) -> + let sym = Z3.mk_string_symbol ctx ("fld_const_"^(Fld.name f)) in + let f' = Z3.mk_func_decl ctx sym [|x.c.p_sort|] x.c.p_sort in + let inv = Z3.mk_func_decl ctx (Z3.mk_string_symbol ctx "inv") [|x.c.p_sort|] x.c.p_sort in + Z3.mk_app ctx inv [|Z3.mk_app ctx f' [|to_z3_weak x e|]|] + + | E.App({HC.desc= E.App({HC.desc= E.Idx}, i)}, a) -> + let sym = Z3.mk_string_symbol ctx "idx" in + let f' = Z3.mk_func_decl ctx sym [|x.c.p_sort; x.c.i_sort|] x.c.p_sort in + Z3.mk_app ctx f' [|to_z3_weak x a; to_z3_weak x i|] + + | E.App _ | E.Idx -> failwithf "to_z3_weak_: malformed expression: %a" E.fmt (E.name d) + + | E.Nil -> + Z3.mk_const ctx (Z3.mk_string_symbol ctx "nil") x.c.p_sort + + | E.Add(f) -> to_z3_weak x (E.mkAdd (E.mkBas (Fld.typ f)) f) + | E.Sub(f) -> to_z3_weak x (E.mkSub (E.mkBas (Fld.typ f)) f) + + | E.Bas(ty) -> + let eps = Z3.mk_func_decl ctx (Z3.mk_string_symbol ctx "eps") [|x.c.t_sort|] x.c.p_sort in + let sym = Z3.mk_string_symbol ctx ("typ_const_"^(string_of_int (Typ.id ty))) in + let ty' = Z3.mk_const ctx sym x.c.t_sort in + Z3.mk_app ctx eps [|ty'|] + + | E.Eq(e,f) -> Z3.mk_eq ctx (to_z3_weak x e) (to_z3_weak x f) + + | E.OpN(E.Distinct,es) -> Z3.mk_distinct ctx (Array.map (fun e -> to_z3_weak_ x e) es) + + | E.Op1(E.Not,e) -> Z3.mk_not ctx (to_z3_weak_ x e) + | E.OpN(E.And,cn) -> Z3.mk_and ctx (Array.map (to_z3_weak_ x) cn) + | E.OpN(E.Or,dn) -> Z3.mk_or ctx (Array.map (to_z3_weak_ x) dn) + + | E.Op3(E.Ite,g,t,E.Num(n)) when E.is_pointer (E.name t) && n < 0L -> + let name = "ptr_const_"^(Int64.to_string (Int64.neg n)) in + let n' = Z3.mk_const ctx (Z3.mk_string_symbol ctx name) x.c.p_sort in + Z3.mk_ite ctx (to_z3_weak_ x g) (to_z3_weak_ x t) n' + + | E.Op3(E.Ite,g,t,e) -> Z3.mk_ite ctx (to_z3_weak_ x g) (to_z3_weak_ x t) (to_z3_weak_ x e) + + | E.Op1(E.Allocd,e) -> + Z3.mk_app ctx (Z3.mk_func_decl ctx (Z3.mk_string_symbol ctx "Allocd") [|x.c.p_sort|] x.c.b_sort) + [|to_z3_weak_ x e|] + + | E.Num(n) -> + Z3.mk_const ctx (Z3.mk_string_symbol ctx ("int_const_"^(Int64.to_string n))) x.c.u_sort + + | E.Str(s) -> + Z3.mk_const ctx (Z3.mk_string_symbol ctx ("\""^s^"\"")) x.c.p_sort + + | E.Op1(E.ZMin,e) -> + let o' = Z3.mk_string_symbol ctx "ZMin" in + Z3.mk_app ctx (Z3.mk_func_decl ctx o' [|x.c.u_sort|] x.c.u_sort) [|to_z3_weak_ x e|] + + | E.Op2(o,e,f) -> + let name = + match o with + | E.ZDiv -> "ZDiv" | E.ZRem -> "ZRem" | E.ZMod -> "ZMod" + | E.ZLt -> "ZLt" | E.ZLe -> "ZLe" | E.ZGt -> "ZGt" | E.ZGe -> "ZGe" in + let o' = Z3.mk_string_symbol ctx name in + let sort = + match o with + | E.ZDiv | E.ZRem | E.ZMod -> x.c.u_sort + | E.ZLt | E.ZLe | E.ZGt | E.ZGe -> x.c.b_sort in + Z3.mk_app ctx (Z3.mk_func_decl ctx o' [|x.c.u_sort; x.c.u_sort|] sort) + [|to_z3_weak_ x e; to_z3_weak_ x f|] + + | E.OpN(o,es) -> + let name = + match o with + | E.ZAdd -> "ZAdd" | E.ZMul -> "ZMul" | E.UFun(s) -> s + | E.Distinct | E.And | E.Or -> assert false in + let o' = Z3.mk_string_symbol ctx name in + Z3.mk_app ctx (Z3.mk_func_decl ctx o' (Array.map (fun _ -> x.c.u_sort) es) x.c.u_sort) + (Array.map (fun e -> to_z3_weak_ x e) es) + + with exc -> L.printf 20 "to_z3_weak:@ %a" E.fmt (E.name d) ; raise exc + + +let conjoin_weak ?(parts=[]) ({c={z= ctx; s= slv}} as x) bex = + assert(true$> L.printf 10 "Pure.conjoin_weak: %a" E.fmt bex ); + Timer.time conjoin_tmr @@fun()-> + let cnstr = to_z3_weak x bex in +(* L.printf 0 "Pure.conjoin_weak: %a" (Z3.fmt_ast ctx) cnstr ; *) + let assumptions = assumptions x parts in + let imp_cnstr = + if assumptions = [] then cnstr else + Z3.mk_implies ctx (Z3.mk_and ctx (Array.of_list assumptions)) cnstr in + Z3.solver_assert ctx slv imp_cnstr + + +let get_implied_equalities x assumptions terms = + match terms with + | [||] -> Some([||]) + | [|_|] -> Some([|0|]) + | _ -> + let ({c={z= ctx; s= slv}} as x) = + if Config.gie_incremental then x + else + let {c={z= ctx0}} = x in + let ({c={z= ctx; s= slv}} as y) = mk () in + List.iter (fun f -> + Z3.solver_assert ctx slv (Z3.translate ctx0 f ctx) + ) (assertions x []) ; + y + in + let assumptions = Array.map (to_z3_weak x) assumptions in + let terms = Array.map (to_z3_weak x) terms in + match terms with + | [|e;f|] when Z3.is_eq_sort x.c.z (Z3.get_sort x.c.z e) (Z3.get_sort x.c.z f) -> + Z3.solver_push ctx slv ; + Array.iter (Z3.solver_assert ctx slv) assumptions ; + Z3.solver_assert ctx slv (Z3.mk_not ctx (Z3.mk_eq ctx e f)) ; + (match Z3.solver_check ctx slv with + | Z3.L_UNDEF -> None + | Z3.L_FALSE -> Some([|0;0|]) + | Z3.L_TRUE -> Some([|0;1|]) + ) $> + Z3.solver_pop ctx slv 1 + | [|_;_|] -> + Some([|0;1|]) + | _ -> + assert(true$> + L.incf 10 "( get_implied_equalities:@ @[%a@]" (List.fmt "@ " (Z3.fmt_ast ctx)) (Array.to_list terms) ); +(* let {Timer.max= max0; count= count0} = z3_check_tmr in *) +(* z3_check_tmr.Timer.max <- 0. ; *) + Timer.start get_implied_equalities_tmr ; + + Z3.solver_push ctx slv ; + Array.iter (fun a -> Z3.solver_assert ctx slv a) assumptions ; + let sat, ids = + match Config.gie with + | 0 -> Z3.get_implied_equalities_naive ctx slv terms + | 1 -> Z3.get_implied_equalities ctx slv terms + | 2 -> Z3.get_implied_equalities_refine ctx slv terms + | _ -> invalid_arg "unrecognized get_implied_equalities implementation" + in + Z3.solver_pop ctx slv 1 ; + + Timer.stop get_implied_equalities_tmr ; +(* let {Timer.max= max1; count= count1} = z3_check_tmr in *) +(* z3_check_tmr.Timer.max <- max max0 max1 ; *) +(* Timer.log get_implied_equalities_tmr gie_log *) +(* ( (match sat with Z3.L_TRUE -> "SAT" | Z3.L_FALSE -> "UNSAT" | Z3.L_UNDEF -> "UNKNOWN") *) +(* ^ "\t" ^ (string_of_int (Array.length terms)) *) +(* ^ "\t" ^ (string_of_int (count1 - count0)) *) +(* ^ "\t" ^ (string_of_float (max1 *. 1000.)) ) ; *) + + assert(true$> + if sat <> Z3.L_TRUE then + L.decf 10 ") get_implied_equalities:@ %a" Z3.fmt_lbool sat + else + let n = Array.length terms in + let ast_to_idx = PolyHMap.create n in + let id_to_class = IntHMMap.create n in + Array.iteri (fun i e -> + PolyHMap.add ast_to_idx e i ; + IntHMMap.add id_to_class ids.(i) e + ) terms ; + let _, rep = + Array.fold_left (fun (i, rep) e -> + let cmp_ast x y = compare (PolyHMap.find ast_to_idx x) (PolyHMap.find ast_to_idx y) in + (i+1, (e, List.hd (List.sort cmp_ast (IntHMMap.find id_to_class ids.(i)))) :: rep) + ) (0, []) terms in + L.decf 10 ") get_implied_equalities:@ @[%a@]" + (fun ff -> + let aux ff (e,f) = Format.fprintf ff "@[%a/%a@]" (Z3.fmt_ast ctx) f (Z3.fmt_ast ctx) e in + Format.fprintf ff "@[[%a]@]" (List.fmt ",@ " aux) + ) rep ; + if Config.check_gie then ( + Z3.solver_push ctx slv ; + Array.iter (Z3.solver_assert ctx slv) assumptions ; + for i = 0 to n-1 do + for j = i+1 to n-1 do + if Z3.is_eq_sort ctx (Z3.get_sort ctx terms.(i)) (Z3.get_sort ctx terms.(j)) then ( + Z3.solver_push ctx slv ; + Z3.solver_assert ctx slv (Z3.mk_not ctx (Z3.mk_eq ctx terms.(i) terms.(j))) ; + let naive_proved_i_eq_j = (Z3.solver_check ctx slv = Z3.L_FALSE) in + let gie_proved_i_eq_j = (ids.(i) = ids.(j)) in + Z3.solver_pop ctx slv 1 ; + match naive_proved_i_eq_j, gie_proved_i_eq_j with + | true, false -> + failwithf "gie incomplete for %a = %a" + (Z3.fmt_ast ctx) terms.(i) (Z3.fmt_ast ctx) terms.(j) + | false, true -> + failwithf "gie unsound for %a = %a" + (Z3.fmt_ast ctx) terms.(i) (Z3.fmt_ast ctx) terms.(j) + | _ -> () + ) + done + done ; + Z3.solver_pop ctx slv 1 + ) + ); + + if sat = Z3.L_UNDEF then + None + else + Some(ids) diff --git a/src/Pure.mli b/src/Pure.mli new file mode 100644 index 0000000..a926ff5 --- /dev/null +++ b/src/Pure.mli @@ -0,0 +1,78 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Pure formulas and theorem prover *) + +open Variable +open Expression + + +val z3_assert_tmr : Timer.t +val z3_push_tmr : Timer.t +val z3_pop_tmr : Timer.t +val z3_check_tmr : Timer.t +val z3_check_assumptions_tmr : Timer.t +val z3_eval_tmr : Timer.t +val z3_get_implied_equalities_tmr : Timer.t +val get_implied_equalities_tmr : Timer.t +val find_provable_equality_tmr : Timer.t +val conjoin_tmr : Timer.t +val inconsistent_tmr : Timer.t +val implies_tmr : Timer.t + + +(*============================================================================ + Pure + ============================================================================*) + +(** A logical context. *) +type t + +(** A vertical (orthogonal to extension) partition of a tree of contexts. *) +type partition + + +(** [mk_partition x] creates a new partition of [x]. *) +val mk_partition : t -> partition + +(** [mk ()] creates a new tree of contexts. *) +val mk : unit -> t + +(** [clear x] retracts (and deallocates) all constraints and partitions from + [x]. *) +val clear : t -> unit + +(** [extend x] adds and returns an empty context that extends [x]. *) +val extend : t -> t + +(** [conjoin ps x b] conjoins [b] to the intersection of the [ps] partitions + of [x]. *) +val conjoin : ?parts:partition list -> + t -> Exp.t -> unit + +(** [implies ps x b] holds only if the union of the [ps] partitions of [x] + implies [b]. *) +val implies : ?parts:partition list -> + t -> Exp.t -> bool option + +(** [impliesx ps x (vs,b)] holds only if the union of the [ps] partitions + of [x] impliex [? vs. b]. *) +val impliesx : ?parts:partition list -> + t -> Vars.t * Exp.t -> bool option + +(** [inconsistent ps x] holds if and only if [implies ps x E.ff]. *) +val inconsistent : ?parts:partition list -> + t -> bool + + +type find_provable_equality_t = + | Inconsistent + | Equality of Exp.t * Exp.t + | Disjunctions of (Exp.t * Exp.t) list list + +val find_provable_equality : ?parts:(partition list) -> + t -> Exps.t -> Exps.t -> (Exp.t -> Exp.t -> bool) -> find_provable_equality_t + + +val conjoin_weak : ?parts:partition list -> t -> Exp.t -> unit + +val get_implied_equalities : t -> Exp.t array -> Exp.t array -> int array option diff --git a/src/README b/src/README new file mode 100644 index 0000000..f175b26 --- /dev/null +++ b/src/README @@ -0,0 +1,22 @@ +Instructions for building + + +The Makefile depends on SLAyer/config.sh having been sourced: + $ source ../config.sh + + +- To compile debug (byte and native) code: + $ make dbg + +- To compile optimized (native) code: + $ make opt + + Executables are dropped in ../bin + +Warning: The dependency tracking for the OCaml Z3 bindings is not +robust enough to recover from failed builds, so if the make falls over +while trying to build z3dll, execute 'make clean_mlz3' before retrying +'make'. + +- To compile only a single module (and its dependencies): + $ make M= module diff --git a/src/README.txt b/src/README.txt new file mode 100644 index 0000000..f175b26 --- /dev/null +++ b/src/README.txt @@ -0,0 +1,22 @@ +Instructions for building + + +The Makefile depends on SLAyer/config.sh having been sourced: + $ source ../config.sh + + +- To compile debug (byte and native) code: + $ make dbg + +- To compile optimized (native) code: + $ make opt + + Executables are dropped in ../bin + +Warning: The dependency tracking for the OCaml Z3 bindings is not +robust enough to recover from failed builds, so if the make falls over +while trying to build z3dll, execute 'make clean_mlz3' before retrying +'make'. + +- To compile only a single module (and its dependencies): + $ make M= module diff --git a/src/Reachability.ml b/src/Reachability.ml new file mode 100644 index 0000000..a3a5ede --- /dev/null +++ b/src/Reachability.ml @@ -0,0 +1,266 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Reachability via pointers in symbolic heaps *) + +open Library + +open Type +open Variable +open Expression +module E = Exp +open SYMBOLIC_HEAP +open SymbolicHeap +open TransRel +module Ends = BiEdge.Poly + +module L = (val Log.std Config.vRch : Log.LOG) + + +(* Timing =================================================================== *) + +let reachability_graphs_tmr = + Timer.create "Reachability.reachability_graphs" + + +(* Tracing ================================================================== *) + +let fmt ff rgm = + let fmt_lbl_rg ff (lbl,rg) = + Format.fprintf ff "@[%2i: %a@]" lbl ExpTransRel.fmt rg + in + Format.fprintf ff "@[%a@]" (List.fmt "@\n" fmt_lbl_rg) (IntMap.to_list rgm) + + +(*============================================================================ + Reachability Graphs + ============================================================================*) + +exception FoundPath of Typ.t * Fld.t list + +module ShFrm = struct + include SH + module Exp = Exp + module Exps = Exps + module ExpMap = ExpMap + + let is_leaf q = DjS.is_empty q + + let fold_rels add_scc add_edg q z = + let rec concretize_lists xs sh = + SH.LsS.fold (fun ({Ls.pat} as ls) concretized_lss -> + let vs, fnt, bck = Ls.split_on_fresh_point ls in + let vxs = Vars.union vs xs in + let fnt = Patn.instantiate pat fnt in + let bck = Patn.instantiate pat bck in + let fs, fnt = XSH.exists_bind vxs fnt in + let bs, bck = XSH.exists_bind vxs bck in + let vfbs = Vars.union (Vars.union vs fs) bs in + let vfbxs = Vars.union vfbs xs in + let fnt = concretize_lists vfbxs fnt in + let bck = concretize_lists vfbxs bck in + let fnt = XSH.exists_intro fs fnt in + let bck = XSH.exists_intro bs bck in + XSH.exists_intro vs (XSH.star [fnt; bck] concretized_lss) + ) sh (SH.exists_intro Vars.empty (SH.LsS.empty sh)) + in + let _,q = XSH.exists_bind Vars.empty (concretize_lists Vars.empty q) + in + let add_edg loc cnt z = + if Exp.sort_of cnt <> Var.PointerSort then z else + add_edg loc cnt z + in + let base_to_type = + SH.PtS.fold (fun {Pt.loc; off} base_to_type -> + let obj_typ, fld_path = + match Off.desc off with + | Off.Path(ty,fs) -> + (ty,fs) + | Off.Var(v) -> + try + Exps.iter (fun e -> + match Off.desc (Off.mk e) with + | Off.Path(ty,fs) -> raise (FoundPath(ty,fs)) + | _ -> () + ) (SH.Pf.class_of q (E.mkVar v)) ; + failwithf "unexpected Var offset: %a" Var.fmt v + with FoundPath(ty,fs) -> + (ty,fs) + in + let obj_bas = SH.Pf.normalize q (E.mkSubs loc fld_path) + in + ExpMap.add obj_bas obj_typ base_to_type + ) q ExpMap.empty + in + z + |> + SH.Pf.fold_classes (fun e _ z -> + if Exp.is_pointer e then + add_scc [e] z + else + z + ) q + |> + ExpMap.fold (fun bas typ z -> + let locs = + List.fold (fun (_,fs,_ty) locs -> + let loc = SH.Pf.normalize q (E.mkAdds bas fs) in + if SH.Pf.mem_carrier loc q + then loc :: locs + else locs + ) (Typ.all_paths typ) [] + in + add_scc locs z + ) base_to_type + |> + SH.PtS.fold (fun {Pt.loc; cnt} z -> + Option.fold (add_edg loc) cnt z + ) q + + let fold_nrels _ _ z = z + +end + +module CngRel = struct + include CngRel + type exp = Exp.t + type exps = Exps.t +end + +module HG = ExpTransRel + + +module DTC = DisjTransClos.Make (ShFrm) (CngRel) (SH) (HG) + + +(** [reachability_graphs sh] computes a map from each label of [sh] to a heap + graph representing the reachability relation for that branch. *) +let reachability_graphs sh = + assert(true$> + L.incf 5 "( reachability_graphs:@ %a" SH.fmt sh ); + Timer.start reachability_graphs_tmr ; + (fun rgm -> + Timer.stop reachability_graphs_tmr ; assert(true$> + L.decf 5 ") reachability_graphs:@ %a" fmt rgm )) + <& + DTC.dtc sh + +(* let reachability_graphs sh = debug_wrap1 Config.vRch 5 reachability_graphs sh *) + + +(*============================================================================ + Is-Reachable + ============================================================================*) + +(** [is_reachable root sh dt loc] holds if the branch of [sh] for [dt] proves + that [loc] is reachable from an expression satisfying [root]. *) +let is_reachable root sh = + let rgm = reachability_graphs sh in + fun dt loc -> + let rg = IntMap.find (SH.lbl dt) rgm in + let loc' = SH.Pf.normalize dt loc in + let root = (fun e -> Exps.exists root (SH.Pf.class_of dt e)) in + root loc || (HG.is_reachable root rg loc') +(* + let preds = Exps.add loc (HG.predecessors rg loc') in + Exps.exists (fun e -> Exps.exists root (SH.Pf.class_of dt e)) preds +*) + +(*============================================================================ + Abstraction + ============================================================================*) + +(* holds only if intermediate allocs are existential *) +let intermediate_allocs_existential xs edg edg' = + L.incf 2 "( intermediate_allocs_existential:@ @[%a@ %a@]" HeapGraph.Edge.fmt edg HeapGraph.Edge.fmt edg' ; + L.decf 2 ") intermediate_allocs_existential:@ %b" + <& + let {back= back} = edg + and {frnt= frnt'} = edg' + in + let allocs_are_existential links = + List.for_all (function + | Some(a) -> Vars.intersect xs (E.fv a) + | _ -> false + ) links + in + allocs_are_existential back + && allocs_are_existential frnt' + + +(* holds only if edges not pointing back into themselves *) +let acyclic edg edg' = + L.incf 2 "( acyclic:@ @[%a@ %a@]" HeapGraph.Edge.fmt edg HeapGraph.Edge.fmt edg' ; + L.decf 2 ") acyclic:@ %b" + <& + let {prev= prev; frnt= frnt; back= back} = edg + and {frnt= frnt'; back= back'; next= next'} = edg' + in + let add_dangles = List.fold (Option.fold Exps.add) in + let dangles = add_dangles prev (add_dangles next' Exps.empty) + in + let allocs_disjoint_dangles links = + List.for_all (function + | Some(a) -> not (Exps.mem a dangles) + | _ -> true + ) links + in + allocs_disjoint_dangles frnt + && allocs_disjoint_dangles back + && allocs_disjoint_dangles frnt' + && allocs_disjoint_dangles back' + + +(* holds only if e and f have same reachability predecessors *) +let same_predecessors rgm xs sh e f = + L.incf 2 "( same_predecessors:@ @[%a@ %a@]" E.fmt e E.fmt f ; + L.decf 2 ") same_predecessors:@ %b" + <& + let rg = IntMap.find (SH.lbl sh) rgm + in + let us = Vars.diff (SH.fv sh) xs + in + let univ_preds b = + Exps.fold (fun a preds -> + Exps.union + (Exps.filter (fun a' -> Vars.subset (E.fv a') us) + (SH.Pf.class_of sh a)) + preds + ) (HG.predecessors rg (SH.Pf.normalize sh b)) Exps.empty + in + Exps.equal (univ_preds e) (univ_preds f) + + +(* holds only if allocs of edges have same reachability predecessors *) +let allocs_same_predecessors rgm xs sh edg edg' = + L.incf 2 "( allocs_same_predecessors:@ @[%a@ %a@]" HeapGraph.Edge.fmt edg HeapGraph.Edge.fmt edg' ; + L.decf 2 ") allocs_same_predecessors:@ %b" + <& + let {frnt= frnt; back= back} = edg + and {frnt= frnt'; back= back'} = edg' + in + let rec allocs_same_predecessors_ es fs = + match es, fs with + | Some(e)::es, Some(f)::fs -> + same_predecessors rgm xs sh e f + && allocs_same_predecessors_ es fs + | [], [] -> + true + | _ -> + false + in + allocs_same_predecessors_ frnt frnt' + && allocs_same_predecessors_ back back' + + +(** Determine whether to abstract two edges into one, based on whether the + intermediate allocs are existential, the same universal expressions reach + to the allocs of the edges, and the edges are not cyclic. *) +let should_append (xs,sh) = + let rgm = reachability_graphs sh in + fun edg edg' dt -> + L.incf 2 "( should_append:@ @[%a@ %a@]" HeapGraph.Edge.fmt edg HeapGraph.Edge.fmt edg' ; + L.decf 2 ") should_append:@ %b" + <& let()=()in + intermediate_allocs_existential xs edg edg' + && acyclic edg edg' + && allocs_same_predecessors rgm xs dt edg edg' diff --git a/src/Reachability.mli b/src/Reachability.mli new file mode 100644 index 0000000..4999c00 --- /dev/null +++ b/src/Reachability.mli @@ -0,0 +1,23 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Reachability via pointers in symbolic heaps *) + +open Variable +open Expression +open SymbolicHeap +open SYMBOLIC_HEAP + + +val reachability_graphs_tmr : Timer.t + + +(** [is_reachable root sh dt loc] holds if the branch of [sh] for [dt] proves + that [loc] is reachable from an expression satisfying [root]. *) +val is_reachable : (Exp.t -> bool) -> SH.t -> SH.t -> Exp.t -> bool + + +(** Determine whether to abstract two edges into one, based on whether the + intermediate allocs are existential, the same universal expressions reach + to the allocs of the edges, and the edges are not cyclic. *) +val should_append : + (Vars.t * SH.t) -> (Exp.t option) edg -> (Exp.t option) edg -> SH.t -> bool diff --git a/src/RemoveUnusedGlobals.ml b/src/RemoveUnusedGlobals.ml new file mode 100644 index 0000000..38ef47c --- /dev/null +++ b/src/RemoveUnusedGlobals.ml @@ -0,0 +1,128 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(******************** + This does not deal optimally with the following case: + + T foo; + PT pfoo = &foo; + + If foo is used in the program, but pfoo is never used. The analysis + overaproximates flows, and thus will not remove pfoo, even though it + would be safe to do so. + +*********************) + +open Library + +open Variable +open Program +module I = Inst +module C = Cmnd +module K = ControlPoint + +let rec remove_vars_from_proc procs vars id = + let open Proc in + try + let proc = IdHMap.find procs id in + let entry = proc.entry in + let entry = K.id entry in + let cfg = proc.cfg in + let to_nop = + CFG.fold_edges (fun _ m -> m) + (fun (s,c,e) to_nop -> + match c with + | C.Call{Call.proc} -> + remove_vars_from_proc procs vars proc ; + to_nop + | C.ICall _ -> failwith "Not expecting this" + | C.Inst _ -> + if Vars.intersect (C.fv c) vars then + (s, c, e) :: to_nop + else + to_nop + ) cfg entry [] in + let nop_it (s,c,e) = +(* Format.printf "Remove@ @[(%a,@ %a,@ %a)@]@\n" K.fmt s C.fmt c K.fmt e;*) + CFG.remove_edge cfg s c e ; + CFG.add_edge cfg s (C.Inst(I.mk I.Nop (K.pos s))) e + in + List.iter nop_it to_nop + with + Not_found -> () + +let remove_unused_globals ({Prog.procs; globals; main; global_setup; inits} as prog) = + if not Config.optimize_unused then prog else + (* This assumes main is not called by something else, but I think a lot of code makes that assumption. If it + is called by something else, this analysis will not find any unused globals. *) + (* This should be called before inlining, as the allocate and deallocate global routines will be inline. *) + let open Proc in + (* Calculate used globals *) + let mainproc = Proc.IdHMap.find procs main in + + let get_proc id = Option.get (Proc.IdHMap.tryfind procs id) in + let accessed id = (get_proc id).Proc.accessed in + (* Initially assume all globals are unused, and remove everything that is used *) + let remove_used id m = + if List.mem id global_setup then + (* If these are the calls to do the creatation/initialisation and disposal, then ignore them *) + m + else + Vars.diff m (accessed id) + in + (* Traverse main removing everything that is accessed *) + let unused = + CFG.fold_edges (fun _ m -> m) (fun (_,c,_) m -> + let m = Vars.diff m (C.fv c) in + match c with + | C.Inst _ -> + m + | C.Call{Call.targets} + | C.ICall{Call.targets} -> + List.fold remove_used targets m + ) mainproc.cfg (K.id mainproc.entry) globals + in + (* To deal correctly with initialisation of globals, that uses other + globals, e.g. + T foo; + PT pfoo = &foo; + For any initialiser, that accesses a used variable, make all + other variables it accesses used as well. *) + let up = ref false in (* Used to find fixedpoint *) + let remove_used_if_accessed_used proc unused = + let access_used, access_unused,_ = Vars.diff_inter_diff (accessed proc) unused in + (* Second disjunct is require for termination, as if this is empty, no work will be done *) + if Vars.is_empty access_used || Vars.is_empty access_unused then + unused + else ( + up := true ; + Vars.diff unused access_unused + ) in + (* The interation here is potentially expensive, if there is a long initialisation chain*) + let rec work unused = + let unused = + List.fold (fun id unused -> + let proc = get_proc id in + CFG.fold_edges (fun _ m -> m) (fun (_,c,_) m -> + match c with + | C.Inst {Inst.desc = Inst.Nop} -> m + | C.Inst _ -> + (* MJP: the static and dynamic initialisers should just call the initialisers for each variable, + they don't do their own work. *) + assert false + | C.Call{Call.targets} + | C.ICall{Call.targets} -> + List.fold remove_used_if_accessed_used targets m + ) proc.cfg (K.id proc.entry) unused + ) inits unused in + if !up then ( + up := false ; + work unused + ) + else + unused + in + let unused = work unused in + + (* Filter unused globals *) + List.iter (remove_vars_from_proc procs unused) global_setup ; + {prog with Prog.globals = Vars.diff globals unused} diff --git a/src/SYMBOLIC_HEAP.ml b/src/SYMBOLIC_HEAP.ml new file mode 100644 index 0000000..e43c0a6 --- /dev/null +++ b/src/SYMBOLIC_HEAP.ml @@ -0,0 +1,433 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Signatures describing Symbolic Heap formulas *) + +open Library + +open Variable +open Expression + + +(*TERM========================================================================*) + +(** Common interface of formulas *) +module type TERM = sig + type t + + val fv : t -> Vars.t + (** set of free variables *) + + val map_exps : (Exp.t -> Exp.t) -> t -> t + (** map over subexpressions *) + + val fold_exps : (Exp.t -> 'a -> 'a) -> t -> 'a -> 'a + (** fold over all expressions and their subexpressions *) + + val compare : t -> t -> int + (** comparison *) + + val equal : t -> t -> bool + (** equality *) + + val fmt : t formatter + (** human-readable presentation *) + + val fmtp : Var.fxt -> t formatter + (** human-readable presentation using a variable formatting context to prettify quantified variables *) + + val fmt_caml : t formatter + (** [fmt_caml x] emits caml code that constructs [x]. *) + +end + + +(*BIEDGE======================================================================*) + +type 'a edg = { prev: 'a list; frnt: 'a list; back: 'a list; next: 'a list } + (** {v + frnt back + .----. .----. next + | --+--> | --+--> + prev |----| ... |----| + <--+- | <--+-- | + '----' '----' v} *) + +(** Interface for labeled bi-directional multi-edges *) +module type POLY_BIEDGE = sig + + val map : ('a -> 'b) -> 'a edg -> 'b edg + + val map2 : ('a->'b->'c) -> 'a edg -> 'b edg -> 'c edg + +(* val fold : ('a -> 'z->'z) -> 'a edg -> 'z->'z *) + + val fold2 : ('a->'b -> 'z->'z) -> 'a edg -> 'b edg -> 'z->'z + + val fold_links : ('a*'a -> 'z->'z) -> 'a edg -> 'z->'z + + val fold_links2 : ('a*'a -> 'b*'b -> 'z->'z) -> 'a edg -> 'b edg -> 'z->'z + + val may_allocs : 'a edg -> 'a list + +(* val reverse : 'a edg -> 'a edg *) + (** [reverse] [p,f,b,n] = [n,b,f,p] *) + + val between : 'a edg -> 'a edg -> 'a edg + (** [between] [s, t;t', u, v;v'] [w, x;x', y, z;z'] + = [u, v;v', w, x;x'] *) + + val append : 'a edg -> 'a edg -> 'a edg + (** [append] [p, f;f', i, j;j'] [k, l;l', b, n;n'] + = [p, f;f', b, n;n'] *) + + val split : 'a list -> 'a list -> 'a edg -> 'a edg * 'a edg + (** [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]. Eg: + [split] w x + [u, v, y, z] + = ([u, v, w, x], + [w, x , y, z]) *) + + val remove_prefix : 'a edg -> 'a edg -> 'a edg * 'a edg + (** [remove_prefix wy xz = (wx, yz)] such that if [wx] is empty, then + [append wy yz = xz]. That is, + [remove_prefix [s, t , u, v] + [w, x , y, z] + = ([s, t, w, x], [u, v, y, z])] *) + + val remove_suffix : 'a edg -> 'a edg -> 'a edg * 'a edg + (** [remove_suffix xz wy = (yz, wx)] such that if [yz] is empty, then + [append wx xz = wy]. That is, + [remove_suffix [s, t , u, v] + [w, x, y, z] + = ( [y, z, u, v], + [w, x, s, t] )] *) + +end + +module type BIEDGE = sig + + include POLY_BIEDGE + + type a + type t = a edg + + include (TERM with type t := t) + +(* val adjacent : t -> t -> bool *) + (** [adjacent x y] holds if [x] and [y] are adjacent. Eg: + [adjacent] [p, f;f', i , j ;k] + [i', j';k', b, n;n'] + holds if i = i' & j = j' & k = k' *) + +end + + +(*FORMULAS====================================================================*) + +(** Common interface of sets of subformulas of Symbolic Heaps *) +module type FORMULAS = sig + include Set.Q + val star : elt list -> t -> t + val remove : elt -> t -> t + val empty : t -> t +end + + +(*COMMON_SH===================================================================*) + +(** Common interface of quantified and quantifier-free Symbolic Heap formulas *) +module type COMMON_SH = sig + include TERM + + type xsh + type vs_t + + (** {7 Constructors } *) + + val emp : t + val tt : t + val ff : t + + (** *-conjunction *) + val star : t list -> t -> t + + (** disjunction *) + val disj : t list -> t -> t + + (** apply a substitution to a formula *) + val subst : Substitution.t -> t -> t + + (** [rename_vs vs q] generates a substitution [s] from [vs] to fresh + variables and calls [rename s q]. *) + val rename_vs : Vars.t -> t -> t * Vars.t * Substitution.t * Substitution.t + + (** [exists_intro vs q] is equivalent to [? vs. q] but where some of the + existential quantifiers may have been eliminated. *) + val exists_intro : Vars.t -> t -> xsh + + (** {7 Normalization } *) + + val normalize : ?dnf:bool -> ?init:t -> vs_t -> vs_t + + val normalize_stem : ?init:t -> vs_t -> vs_t * Exps.t + + (** {7 Queries } *) + + (** [inconsistent q] holds if [q] is syntactically inconsistent. See also + [Prover.inconsistent]. *) + val inconsistent : t -> bool + + (** [is_empty q] holds only if [q] entails [emp]. + Incomplete in the presence of inconsistent disjuncts. *) + val is_empty : t -> bool + + (** [is_pure q] holds only if [q] is pure. Tests if [q] is of form [p * tt] + for some pure formula [p], and is further incomplete in the presence of + inconsistent disjuncts. *) + val is_pure : t -> bool + + (** [sizeof q] is a measure of the syntactic size of [q] *) + val sizeof : t -> int + + val lbl : t -> int + val set_lbl : int -> t -> t + + val fmt_xs : vs_t formatter + val fmtp_xs : Var.fxt -> vs_t formatter + val fmt_did : t * t -> (Format.formatter->unit) * (Format.formatter->unit) * (Format.formatter->unit) + val fmt_did_xs : vs_t * vs_t -> (Format.formatter->unit) * (Format.formatter->unit) * (Format.formatter->unit) + +end + + +(*SH==========================================================================*) + +(** (quantifier-free) Symbolic Heap formulas *) +module type QUANTIFIER_FREE_SYMBOLIC_HEAP = sig + type t + type pt type ls type dj type xsh + + include COMMON_SH + with type t := t and type xsh := xsh and type vs_t = Vars.t * t + + type f = Pt of pt | Ls of ls | Dj of dj + + (** {6 SH-specific operations } *) + + (** {7 Subformulas } *) + + (** Pure subformula *) + module Pf : sig + val star : Exp.t list -> t -> t + + val term : t -> Exp.t + (** Return pure part of SH's stem as a boolean formula. *) + + val normalize : t -> Exp.t -> Exp.t + (** [normalize q e] maps [e] to the representative of its congruence + class induced by [q]. *) + + val mem_carrier : Exp.t -> t -> bool + + val class_of : t -> Exp.t -> Exps.t + (** [class_of q e] is the equivalence class of [e] induced by [q]. *) + + val carrier : t -> Exps.t + + val classes : t -> Expss.t + + val fold_classes : (Exp.t -> Exps.t -> 'z -> 'z) -> t -> 'z -> 'z + + val empty : t -> t + + val trim : Vars.t -> Exps.t -> Substitution.t -> t -> t + (** [trim xs ts s q] is [q'] where [q'] is [q] but with the congruence relations trimmed to not mention + the domain of [s], using the range instead, and excluding trivial equations on [ts]. New + representatives are chosen attempting to avoid [xs]. *) + + val union : (Exp.t -> Exp.t -> bool) -> t -> t -> t + + val merge : (Exp.t -> Exp.t -> bool) -> t -> Exp.t -> Exp.t -> t + + val extend : Vars.t -> t -> Exp.t -> t + (** [extend xs q e] is logically equivalent to [q] but [e] is included in + the carrier. New representatives are chosen attempting to avoid [xs]. *) + + val mem : Exp.t -> t -> bool + + end + + (** Set of Points-To subformulas *) + module PtS : sig + include FORMULAS with type elt := pt and type t := t + val find : Exp.t -> t -> pt + val may_allocs : t -> Exps.t + end + + (** Set of List-Segment subformulas *) + module LsS : sig + include FORMULAS with type elt := ls and type t := t + val find : Exp.t -> t -> ls + val may_allocs : t -> Exps.t + end + + (** Set of Disjunction subformulas *) + module DjS : sig + include FORMULAS with type elt := dj and type t := t + val add : dj -> t -> t (* To be removed *) + val filter : (dj -> bool) -> t -> t + val extract_all : t -> t * t + val fold_semiring : ('z->'z->'z)-> ('z->'z->'z)-> (t->'z)-> t->'z->'z + end + + (** Junk subformula *) + module Jnk : sig + val star : t -> t + val remove : t -> t + + (** [is_empty q] fails only if [q] is intuitionistic. Tests if [q] is not + of form [p * tt] for some formula [p], and is further incomplete in the + presence of inconsistent disjuncts. *) + val is_empty : t -> bool + end + + (** [exists_elim (xs,q)] is [(ys,r)] where [? ys. r] is logically equivalent + to [? xs. q], optimally syntactically simplified by eliminating some of + the existentially quantified variables [xs]. *) + val exists_elim : ?dnf:bool -> Vars.t * t -> Vars.t * t + + + (** {7 Destructors } *) + + (** [pure_consequences q] is [(ps,c,d)] where + [?xs. q ==> (?ps,xs. c ^ d) /\ (!ps.?xs. c ==> d)]. *) + val pure_consequences : t -> Vars.t * Exp.t * Exp.t + val labeled_pure_consequences : t -> Exp.t * Exp.t IntMap.t + + (** [pure_sf q] is the strongest pure syntactic subformula of [q]. *) + val pure_sf : t -> Exp.t + + (** [spatial_sf q] is the weakest syntactic subformula of [q] such that + [pure_sf q] ^ [spatial_sf q] implies [q]. *) + val spatial_sf : t -> t + + val partition : (f -> bool) -> t -> t * t + + (** [diff_inter_diff p q] returns [(p_q,i,q_p)] where [p = p_q * i] and [q = + q_p * i], such that [p_q] includes pure consequences of [p] that are not + consequences of [p_q], but [q_p] does not. *) + val diff_inter_diff : ?pas:bool -> t -> t -> t * t * t + + + (** {7 Iterators } *) + +(* val iter_post : (t -> t -> unit) -> t -> unit *) + +(* val bfold : (t-> 's-> 'z-> 's) -> (t-> 's-> 'z-> 'z) -> t-> 's-> 'z-> 'z *) + val fold : (t -> 'z -> 'z) -> t -> 'z -> 'z + + val fold_sp : (t -> 's -> 's) -> (t -> 's -> 'p -> 'p) -> t -> 's -> 'p -> 'p + +(* val deprecated_foldi : *) +(* ((int*int)list -> t -> 'z->'z) -> ((int*int)list -> t -> 'z->'z) -> *) +(* t -> 'z -> 'z *) + + val fold_dnf : ?dnf:bool -> (t -> 'c*'d -> 'c*'d) -> ('c*'d -> 'd) -> t -> 'c->'d -> 'd + + val map : (t -> t) -> t -> t + + val map_fold : (t -> 'z -> t * 'z) -> t -> 'z -> t * 'z + + val map_fold_distrib : (t -> 'z -> t * 'z) -> t -> 'z -> t * 'z + +(* val fold_filter : (f -> 'z -> 'z option) -> t -> 'z -> t * 'z *) + + val dcc : t -> (CngRel.t * CngRel.t) IntMap.t + + + (** {7 Queries } *) + + (** set of free variables *) + val fv : ?include_cng_rels:bool -> t -> Vars.t + + (** [find e q] returns the subformula of the stem of [q] that may allocate + [e], raises Not_found if [q] contains no such subformula. *) + val find : Exp.t -> t -> f + val tryfind : Exp.t -> t -> f option + + (** [must_allocs q] is an under-approximation of the allocated locations of [q] *) + val must_allocs : t -> Exps.t + + (** [may_alloc_stem q] is an over-approximation of the allocated locations + of the stem of [q] *) + val may_allocs_stem : t -> Exps.t + + (** [may_allocs q] is an over-approximation of the allocated locations of + [q] *) + val may_allocs : t -> Exps.t + + + (** {7 Formatting } *) + + val mk_fxt : Vars.t * t -> Var.fxt + + val fmtsp : t -> Var.fxt -> t formatter + (** human-readable presentation accepting a super-formula to reduce repeated equalities, + and using a variable formatting context to prettify quantified variables *) + +end + + +(*XSH=========================================================================*) + +(** eXistentially quantified Symbolic Heap formulas *) +module type EXISTENTIAL_SYMBOLIC_HEAP = sig + type t + type pt type ls type dj type sh + + include COMMON_SH with type t := t and type xsh := t and type vs_t := t + + + (** {6 XSH-specific operations } *) + + (** [exists_bind vs q] alpha-converts the existentially quantified variables + of [q] to be disjoint from [vs] and then destructs the quantifier. The + returned bound variables are guaranteed to appear free in the body. *) + val exists_bind : Vars.t -> t -> Vars.t * sh + + + (** {7 Subformulas } *) + + (** Pure Formulas *) + module Pf : sig + val star : Exp.t list -> t -> t + end + + (** Sets of Subformulas *) + module PtS : sig + val star : pt list -> t -> t + end +(* + module LsS : sig + val star : ls list -> t -> t + end + + module DjS : sig + val star : dj list -> t -> t + end +*) + module Jnk : sig + val star : t -> t + val remove : t -> t + end + + + (** {7 Queries } *) + + (** [equivalent p q] returns [Some(s)] if applying [s] to [q] witnesses that + [p] and [q] are equivalent. *) + val equivalent : t -> t -> Substitution.t option + +end diff --git a/src/Statistics.ml b/src/Statistics.ml new file mode 100644 index 0000000..357f6d3 --- /dev/null +++ b/src/Statistics.ml @@ -0,0 +1,109 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +module SH = SymbolicHeap + + +let report pre_analysis_tmr analysis_tmr post_analysis_tmr = + + if Config.stats then ( + let duration = Timer.init.Timer.uduration +. Timer.init.Timer.sduration in + let fmt_tmr {Timer.uduration; sduration; max; count; name} = + if count <> 0 then + let usduration = uduration +. sduration in + Printf.printf " %-40s\ + \ %3.f (%2.f) %%\ + \ %12.6f (%12.6f) sec\ + \ %7i calls %12.6f ms/call %15.3f ms max\n" + name + (100. *. (usduration /. duration)) + (100. *. (sduration /. duration)) + usduration + sduration + count + (1000. *. usduration /. (float count)) + (1000. *. max) + in + let words_to_bytes n = n / (Sys.word_size / 8) in + let bytes_to_MB n = n /. (1024.*.1024.) in + + Printf.printf "STATISTICS:\n" ; + Printf.printf "Time: total %12.6f (%12.6f) sec\n" + duration Timer.init.Timer.sduration ; + Printf.printf " pre-analysis %12.6f (%12.6f) sec\n" + (pre_analysis_tmr.Timer.uduration +. pre_analysis_tmr.Timer.sduration) + pre_analysis_tmr.Timer.sduration ; + Printf.printf " analysis %12.6f (%12.6f) sec\n" + (analysis_tmr.Timer.uduration +. analysis_tmr.Timer.sduration) + analysis_tmr.Timer.sduration ; + Printf.printf " post-analysis %12.6f (%12.6f) sec\n" + (post_analysis_tmr.Timer.uduration +. post_analysis_tmr.Timer.sduration) + post_analysis_tmr.Timer.sduration ; + Printf.printf "\n" ; + fmt_tmr Pure.z3_assert_tmr ; + fmt_tmr Pure.z3_push_tmr ; + fmt_tmr Pure.z3_pop_tmr ; + fmt_tmr Pure.z3_check_tmr ; + fmt_tmr Pure.z3_check_assumptions_tmr ; + fmt_tmr Pure.z3_eval_tmr ; + fmt_tmr Pure.z3_get_implied_equalities_tmr ; + Printf.printf "\n" ; + fmt_tmr Pure.conjoin_tmr ; + fmt_tmr Pure.inconsistent_tmr ; + fmt_tmr Pure.implies_tmr ; + fmt_tmr Pure.find_provable_equality_tmr ; + fmt_tmr Prover.pure_normalize_tmr ; + Printf.printf "\n" ; + fmt_tmr Prover.inconsistent_tmr ; + fmt_tmr Prover.sub_inconsis_m_tmr ; + fmt_tmr Prover.sub_inconsis_s_tmr ; + fmt_tmr Prover.ent_pure_tmr ; + fmt_tmr SH.pure_consequences_tmr ; + fmt_tmr SH.labeled_pure_consequences_tmr ; + Printf.printf "\n" ; + fmt_tmr Prover.entails_tmr ; + fmt_tmr Prover.subtract_tmr ; + Printf.printf "\n" ; + fmt_tmr DisjCngClos.cc_tmr ; + fmt_tmr DisjCngClos.gie_tmr ; + Printf.printf "\n" ; + fmt_tmr Pure.get_implied_equalities_tmr ; + fmt_tmr SH.normalize_tmr ; + fmt_tmr SH.normalize_stem_tmr ; + fmt_tmr SH.exists_elim_tmr ; + fmt_tmr Prover.sh_normalize_tmr ; + fmt_tmr Abstraction.normalize_tmr ; + fmt_tmr SymbolicExecution.normalize_tmr ; + Printf.printf "\n" ; + fmt_tmr Reachability.reachability_graphs_tmr ; + fmt_tmr HeapGraph.add_with_closure_tmr ; + Printf.printf "\n" ; + fmt_tmr Abstraction.abs_junk_tmr ; + fmt_tmr Abstraction.abs_ls_tmr ; + fmt_tmr Abstraction.abs_arith_tmr ; + fmt_tmr Abstraction.abs_pure_tmr ; + fmt_tmr Abstraction.abstract_tmr ; + Printf.printf "\n" ; + fmt_tmr TransRel.add_edge_tmr ; + fmt_tmr TransRel.add_scc_tmr ; + fmt_tmr TransRel.preds_tmr ; + Printf.printf "\n" ; + fmt_tmr Frame.frame_tmr ; + Printf.printf "\n" ; + fmt_tmr Program.unmarshal_tmr ; + fmt_tmr TransformProgram.normalize_tmr ; + Printf.printf "\n" ; + + let len, num, sum, min, med, max = Expression.stats () in + Printf.printf "Expression HashCons table length: %i entries: %i \ + bucket lengths: sum: %i min: %i median: %i max: %i\n" + len num sum min med max ; + Printf.printf "\n" ; + Printf.printf "Memory: total %16.3f MB\n" + (bytes_to_MB (Gc.allocated_bytes())) ; + Printf.printf " maximum %14.3f MB\n" + (bytes_to_MB (float (words_to_bytes + (Gc.get()).Gc.minor_heap_size + (Gc.quick_stat()).Gc.top_heap_words))) ; + Printf.printf " rate %17.3f MB/sec\n" + ((bytes_to_MB (Gc.allocated_bytes())) + /. (Timer.init.Timer.uduration +. Timer.init.Timer.sduration)) ; + ) diff --git a/src/Statistics.mli b/src/Statistics.mli new file mode 100644 index 0000000..0169556 --- /dev/null +++ b/src/Statistics.mli @@ -0,0 +1,4 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + + +val report : Timer.t -> Timer.t -> Timer.t -> unit diff --git a/src/Substitution.ml b/src/Substitution.ml new file mode 100644 index 0000000..f2573b6 --- /dev/null +++ b/src/Substitution.ml @@ -0,0 +1,127 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Expression to expression substitutions *) + +open Library + +open Variable +open Expression +module E = Exp + +module L = (val Log.std Config.vSubst : Log.LOG) + + + +(*============================================================================ + Substitution + ============================================================================*) + +type t = E.t ExpMap.t + + +let equal x y = ExpMap.equal E.equal x y + +let compare x y = ExpMap.compare E.compare x y + + +let fold fn x = ExpMap.fold fn x + +let iter fn x = ExpMap.iter fn x + +let to_assoc x = fold (fun k v al -> (k,v) :: al) x [] + +let to_exp s = E.mkAnd (ExpMap.map_to_array (fun x y -> E.mkEq x y) s) + + +let fmt ff s = + let aux ff (x,e) = Format.fprintf ff "@[%a/%a@]" E.fmt e E.fmt x in + Format.fprintf ff "@[[%a]@]" (List.fmt ",@ " aux) + (to_assoc s) + + +let empty = ExpMap.empty + +let is_empty x = ExpMap.is_empty x + + +let add k v s = if E.equal k v then s else ExpMap.add k v s + +let add_id k v s = ExpMap.add k v s + +let singleton k v = add k v empty + + +let find x s = let x' = ExpMap.find x s in if E.equal x x' then x else x' + +let tryfind x s = try Some(find x s) with Not_found -> None + + +let subst s x = E.pmap (fun x -> tryfind x s) x + + +let of_assoc kvl = List.fold (fun (k,v) s -> add k v s) kvl empty + + +let in_dom x s = ExpMap.mem x s + +let dom x = fold (fun k _ es -> Exps.add k es) x Exps.empty + +let rng x = fold (fun _ v es -> Exps.add v es) x Exps.empty + + +let fv s = + fold (fun e f -> Vars.union (Vars.union (E.fv e) (E.fv f))) s Vars.empty + + +let compose e_x f_y = +(* L.incf 0 "( S.compose: %a %a" fmt e_x fmt f_y ; L.decf 0 ") S.compose: %a" fmt <& *) + ExpMap.merge (fun _k eo fo -> +(* L.printf 0 "k: %a e: %a f: %a g: %a" *) +(* E.fmt _k (Option.fmt "-" E.fmt) eo (Option.fmt "-" E.fmt) fo (Option.fmt "-" E.fmt) <& *) + match eo with + | Some(e) -> Some(subst f_y e) + | None -> fo + ) e_x f_y + + +let remove x s = ExpMap.remove x s + + +let remove_vs vs s = + fold (fun x _ m -> + if Vars.intersect (E.fv x) vs + then remove x m + else m + ) s s + + +(* Note: Is this the right definition, or should Vars.subset be changed? *) +let restrict vs s = + fold (fun x _ m -> + if Vars.subset (E.fv x) vs + then m + else remove x m + ) s s + +let restrict_rng vs s = + fold (fun x e m -> + if Vars.subset (E.fv e) vs + then m + else remove x m + ) s s + + +let meet s t = + fold (fun x e u -> + match tryfind x t with + | Some(f) when E.equal e f -> add x e u + | _ -> u + ) s empty + + +let diff s t = + fold (fun x e u -> + match tryfind x t with + | Some(f) when E.equal e f -> u + | _ -> add x e u + ) s empty diff --git a/src/Substitution.mli b/src/Substitution.mli new file mode 100644 index 0000000..568a843 --- /dev/null +++ b/src/Substitution.mli @@ -0,0 +1,83 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Expression to expression substitutions *) + +open Library + +open Variable +open Expression + + + +(*============================================================================ + Substitution + ============================================================================*) + +type t + +(** {7 Constructors } *) + +val empty : t + +val singleton : Exp.t -> Exp.t -> t + +(** [add] \[E/X\] [y f] = \[[f]/[y], E\[[f]/[y]\]/X\], so [subst (add] + \[E/X\] [y f) D] = [subst] \[f/y\] [(subst] \[E/X\] [D)]. *) +val add : Exp.t -> Exp.t -> t -> t + +(** Like [add] except that identity mappings are retained. *) +val add_id : Exp.t -> Exp.t -> t -> t + +(** [compose] \[E/X\] \[F/Y\] = \[F/Y, E\[F/Y\]/X\], so [subst (compose] + \[E/X\] \[F/Y\][) D] = [subst] \[F/Y\] [(subst] \[E/X\] [D)] = [subst] + \[F/Y, E\[F/Y\]/X\] [D]. *) +val compose : t -> t -> t + +val meet : t -> t -> t + +val diff : t -> t -> t + +(** [remove x] \[E/X\] removes [x] from the domain of \[E/X\]. *) +val remove : Exp.t -> t -> t + +(** [remove_vs vs] \[E/X\] removes [vs] from the domain of \[E/X\]. *) +val remove_vs : Vars.t -> t -> t + +(** [restrict vs] \[E/X\] restricts the domain of \[E/X\] to [vs]. *) +val restrict : Vars.t -> t -> t + +(** [restrict_rng vs] \[E/X\] restricts the domain of \[E/X\] such that the range is contained in [vs]. *) +val restrict_rng : Vars.t -> t -> t + +val of_assoc : (Exp.t * Exp.t) list -> t + +(** {7 Queries } *) + +val to_assoc : t -> (Exp.t * Exp.t) list +val to_exp : t -> Exp.t + +val is_empty : t -> bool + +(** [subst s e] returns [e]\[[f_0]/[d_0],…,[f_n]/[d_n]\] (where [s] is the map + from each [f_i] to [d_i]). *) +val subst : t -> Exp.t -> Exp.t + +val find : Exp.t -> t -> Exp.t + +val tryfind : Exp.t -> t -> Exp.t option + +val dom : t -> Exps.t +val in_dom : Exp.t -> t -> bool + +val rng : t -> Exps.t +val fv : t -> Vars.t + +(** {7 Operations on the underlying representation } *) + +val fold : (Exp.t -> Exp.t -> 'a -> 'a) -> t -> 'a -> 'a + +val iter : (Exp.t -> Exp.t -> unit) -> t -> unit + +val fmt : t formatter +val equal : t -> t -> bool +val compare : t -> t -> int diff --git a/src/SymbolicExecution.ml b/src/SymbolicExecution.ml new file mode 100644 index 0000000..49c2311 --- /dev/null +++ b/src/SymbolicExecution.ml @@ -0,0 +1,806 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Symbolic Execution of commands on symbolic heaps *) + +open Library + +open Type +open Variable +module HC = HashCons +open Expression +module S = Substitution +open SymbolicHeap +open Program +module I = Inst + +include Interproc_sig + +module L = (val Log.std Config.vSE : Log.LOG) + + +(* Timing =================================================================== *) + +let normalize_tmr = Timer.create "SymbolicExecution.SH.normalize" + +module SH = struct include SH + let normalize xsh = + Timer.start normalize_tmr ; + let res = normalize xsh in + Timer.stop normalize_tmr ; + res +end + +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 xs_sh_fmt ff xs_sh = + let norm_fmt ff xs_sh = + let xs, sh = (* SH.normalize *) xs_sh in + Format.fprintf ff "%a%a" + (Vars.fmt_embrace "@[? " " .@]@ ") xs SH.fmt sh in + Format.fprintf ff "@[%a@]" norm_fmt xs_sh + + + +(*============================================================================ + Generic Commands + ============================================================================*) + +(* call[xs'/xs][gs'/gs] \ gs,ys'. pre[ys'/ys] ~> frame + ---------------------------------------------------------------------------- + {?xs.call} !gs.{?ys.pre}{post} ~> {(?gs.post * ?xs',ys',ms.frame)[gs/gs']} + + If global is set, then frame must be empty and + ?gs,ys'.pre[ys'/ys] * frame |- abs( ?xs'.call[xs'/xs][gs'/gs] ) +*) +let exec_gc global cxt call gs ys_pre ms = + (* freshen existentials of pre wrt call *) + let ys', pre = XSH.exists_bind (Vars.union cxt (XSH.fv call)) ys_pre + in + L.printf 6 "@[pre freshened:@ %a@]" xs_sh_fmt (ys',pre) + ; + (* freshen existentials of call wrt gs and ys' *) + let gs_ys' = Vars.union gs ys' in + let xs', call = XSH.exists_bind (Vars.union cxt gs_ys') call + in + L.printf 6 "@[call freshened:@ %a@]" xs_sh_fmt (xs',call) + ; + (* rename ghosts appearing in pre (which includes ys') *) + let call, _, gs_to_gs', gs'_to_gs = + SH.rename_vs (Vars.inter gs (SH.fv pre)) call + in + L.printf 6 "@[call freshened ghosts:@ %a@ %a@]" S.fmt gs_to_gs' SH.fmt call + ; + (* now have input well-formed arguments for subtract, try to find a frame *) + let tryfind_frame call zs pre = + if global then + Prover.entails call zs pre + else + match Prover.subtract call zs pre with + | Prover.Unknown -> None + | Prover.Success(frame,_) -> Some(frame) + in + match tryfind_frame call gs_ys' pre with + | None -> None + | Some(frame) -> + L.printf 6 "@[frame:@ %a@]" XSH.fmt frame + ; + if global && + let pre_frame = XSH.star [ys_pre] frame + in + let abs_call,_ = Abstraction.abstract (SH.exists_intro xs' call) + in + None = Prover.entailsx pre_frame abs_call + then None + else + (* existentially quantify the modified vars out of frame, lift star + between pre and frame above existential on ys', and eliminate the + existential on xs' *) + let frame = XSH.exists_intro (Vars.union (Vars.union xs' ys') ms) frame + in + let post_to_retn post = + (* reconjoin frame *) + let retn = XSH.star [post] frame + in + L.printf 6 "@[post:@ %a@]" XSH.fmt post ; + L.printf 6 "@[frame:@ %a@]" XSH.fmt frame ; + L.printf 6 "@[post * frame:@ %a@]" XSH.fmt retn + ; + (* existentially quantify the ghosts *) + let retn' = XSH.exists_intro gs retn + in + L.printf 6 "@[w/o ghosts:@ %a%a@]" (Vars.fmt_embrace "" "@ ") gs XSH.fmt retn' + ; + (* reinstate the shadowed ghosts *) + let retn = XSH.subst gs'_to_gs retn' + in + let retn = if Prover.inconsistentx retn then XSH.ff else retn + in + L.printf 6 "@[return:@ %a@]" XSH.fmt retn + ; + retn + in + Some(post_to_retn) + + + +(*============================================================================ + Primitive Commands + ============================================================================*) + +exception Error + + +(** [subtractx us q xs f] returns [(ys,r)] such that [q |- ?ys. f * r]. *) +let subtractx cxt q xs footprint = + let vs, q' = XSH.exists_bind (Vars.union cxt xs) q in + match L.shift_verb 3 (fun()-> + Prover.subtract q' xs footprint + ) with + | Prover.Success(remainder, k) -> + assert( L.shift_verb 10 k = Prover.Unknown + || failwithf "ERROR: multiple frames for concretization" ); + let ys = Vars.union vs xs in + (ys, remainder) + | Prover.Unknown -> + raise Error + + +let subtract_field cxt q ys loc cnt = + let off_v = Var.gensym "off" Var.OffsetSort in + let off = Off.mkVar off_v in + let ys = Vars.add off_v ys in + let pt = {Pt.loc; off; cnt} in + let xs, rem = subtractx cxt q ys (SH.PtS.star [pt] SH.emp) in + (xs, pt, rem) + + +(** [subtract_object cxt q loc] checks that [loc] is a pointer to the base of + an object and removes the object: + + q |- ?zs,o. l(@o)->_ * p + p |- o==(t)0 + q |- ?xs. *_{f in t} l(@f)->_ * r + ------------------------------------ + { q } free(l) ~> { ?xs. r } *) + +exception Found of Typ.t + +let subtract_base_field cxt q loc = + let zs, {Pt.off}, rem = subtract_field cxt q Vars.empty loc None in + let xs, rem = XSH.exists_bind (Vars.union zs cxt) rem in + let xs = Vars.union xs zs in + let xs, rem = SH.normalize (xs, rem) in + let off_eqc = SH.Pf.class_of rem (off :>Exp.t) in + let typ = + try + Exps.iter (fun o -> + match Off.is_base (Off.mk o) with + | Some(typ) -> raise (Found(typ)) + | None -> () + ) off_eqc ; + raise Error + with + Found(typ) -> typ in + (typ, xs, rem) + +let subtract_nonbase_fields cxt q loc new_size typ xs rem = + let paths = Typ.all_offsets typ in + if paths = [] then + (Vars.empty, SH.exists_intro xs rem) + else ( + (match new_size with + | Some(n) when n > Typ.sizeof(typ) -> + L.printf 0 "attempted cast from size %Li to %Li" (Typ.sizeof(typ)) n ; + if not Config.trust_casts then raise Error + | _ -> () + ); + let obj = + SH.PtS.star + (List.map (fun (_,path, _fld_typ) -> + {Pt.loc= Exp.mkAdds loc path; off= Off.mkPath typ path; cnt= None} + ) paths) SH.emp in + (* The postcondition computed for free is not strongest, so + normalize to propagate pure consequences of l->_ before + removing it. This produces stronger, but still not strongest, + postconditions. *) + (* Note: revisit this question *) + let q = XSH.normalize q in + subtractx cxt q Vars.empty obj + ) + + +let subtract_object cxt q loc new_size = + let typ, xs, rem = subtract_base_field cxt q loc in + subtract_nonbase_fields cxt q loc new_size typ xs rem + + +(* Trim access paths to the longest array-indexing-free prefix. *) +let rec remove_idx e = + let open Exp in let open HC in + match desc e with + | App({desc= App({desc= Idx},_)},e) -> + remove_idx e + | App(f,e) -> + let e' = remove_idx e in + if Exp.equal e e' then + mkApp f e' + else + e' + | _ -> + e + + +let rec exec_inst cxt i q = + match i with + | I.Assume(b) -> + (* -------------------------- + {q} assume(b) ~> {b * q} *) + let q' = XSH.Pf.star [b] q in + if Prover.inconsistentx q' + then XSH.ff + else q' + + | I.Assert(b) -> + (* q |- b + ---------------------- + {q} assert(b) ~> {q} *) + if Prover.entailsx q (XSH.Pf.star [b] XSH.tt) = None + then raise Error + else q + + | I.Kill(vs) -> + (* ------------------------------ + {q} v := nondet() ~> {?v. q} *) + XSH.exists_intro vs q + + | I.Move(v,e) -> + (* ------------------------------------------ + {q} v := e ~> {?v'. v=e[v'/v] * q[v'/v]} *) + let q', v', v_to_v', _ = XSH.rename_vs (Vars.singleton v) q in + let e' = S.subst v_to_v' e in + XSH.exists_intro v' (XSH.Pf.star [Exp.mkEq (Exp.mkVar v) e'] q') + + | I.Load(v,loc) -> + (* q |- ?xs. l(@o)->c * r + ------------------------------------------------------------- + {q} v := [l] ~> {?v',xs. v==c[v'/v] * (l(@o)->c * r)[v'/v]} *) + let loc' = remove_idx loc in + if Exp.equal loc loc' then + let cnt = Var.gensym "cnt" (Var.sort v) in + let ys = Vars.singleton cnt in + let cnt = Exp.mkVar cnt in + let xs, pt, rem = subtract_field cxt q ys loc' (Some(cnt)) in + let pt_rem = XSH.PtS.star [pt] rem in + let pt_rem, v', v_to_v', _ = XSH.rename_vs (Vars.singleton v) pt_rem in + let xs = Vars.union (Vars.remove v xs) v' in + let cnt = S.subst v_to_v' cnt in + let eq_pt_rem = XSH.Pf.star [Exp.mkEq (Exp.mkVar v) cnt] pt_rem in + XSH.exists_intro xs eq_pt_rem + else + let _ = subtract_field cxt q Vars.empty loc' None in + XSH.exists_intro (Vars.singleton v) q + + | I.Store(loc,cnt) -> + (* q |- ?xs. l(@o)->_ * r + ------------------------------------- + {q} [l] := c ~> {?xs. l(@o)->c * r} *) + let loc' = remove_idx loc in + let xs, pt, rem = subtract_field cxt q Vars.empty loc' None in + let cnt = if Exp.equal loc loc' then Some(cnt) else None in + let pt_rem = XSH.PtS.star [{pt with Pt.cnt}] rem in + XSH.exists_intro xs pt_rem + + | I.Alloc(v,e) -> + (* --------------------------------------- + {q} alloc(v) ~> {?v'. v->_ * q[v'/v]} *) + let q', v', _, _ = XSH.rename_vs (Vars.singleton v) q in + let loc = Exp.mkVar v in + let off = + match Exp.desc e with + | Exp.Num(n) -> Off.mkPath (Typ.mkArray (Typ.mkInt false 1) (Some(n)) n) [] + | _ -> Off.mkPath Typ.mkTop [] in + let cnt = None in + XSH.exists_intro v' (XSH.PtS.star [{Pt.loc; off; cnt}] q') + + | I.Free(loc) -> + (try + let xs, rem = subtract_object cxt q loc None in + XSH.exists_intro xs rem + with Error -> + let loc_eq_nil = XSH.Pf.star [Exp.mkEq loc Exp.nil] XSH.tt in + if Prover.entailsx q loc_eq_nil <> None then + (* q |- l==0 + -------------------- + {q} free(l) ~> {q} *) + q + else + raise Error + ) + | I.Cast(v,ty,loc) -> + let c, q' = + match Exp.convert (Var.sort v) loc with + | None -> + (I.Kill(Vars.singleton v), q) + | Some(loc) -> + let q' = + match Typ.desc ty with + | Typ.Pointer({HC.desc= Typ.Top}) -> + q + | Typ.Pointer(typ) -> + (try + let old_typ, xs, rem = subtract_base_field cxt q loc in + if Typ.equal old_typ typ then + q + else + let xs, rem = subtract_nonbase_fields cxt q loc (Some(Typ.sizeof typ)) old_typ xs rem in + let paths = Typ.all_offsets typ in + let xs, pts = + if paths = [] then + let off = Off.mkPath Typ.mkTop [] in + let cnt = None in + (xs, [{Pt.loc; off; cnt}]) + else + List.fold (fun (_,path, fld_typ) (xs, pts) -> + let loc = Exp.mkAdds loc path in + let off = Off.mkPath typ path in + let cnt_sort = + match Typ.desc fld_typ with + | Typ.Pointer _ -> Var.PointerSort + | _ -> Var.IntegerSort in + let cnt_v = Var.gensym "cnt" cnt_sort in + let cnt = Some(Exp.mkVar cnt_v) in + (Vars.add cnt_v xs, {Pt.loc; off; cnt} :: pts) + ) paths (xs, []) in + XSH.exists_intro xs (XSH.PtS.star pts rem) + with Error -> q) (* attempted to cast an invalid/NULL pointer *) + | _ -> q (* attempted cast to a non-pointer type *) + in + (I.Move(v, loc), q') + in + exec_inst cxt c q' + + | I.Nop -> + q + + | I.Generic({I.ghosts; pre; insts=[]; post}) -> + (* PS#297: ms would be the modified vars if generic commands had them *) + let ms = Vars.empty in + (match exec_gc false cxt q ghosts pre ms with + | Some(post_to_retn) -> post_to_retn post + | None -> raise Error + ) + + | I.Generic({I.ghosts=_ghosts; pre=_pre; insts=_cc; post=_post}) -> + (* Implement the proof rule: + + q |- pre*R + post(pre,cc) = post' + post' |- post + ------------------------------ + {{q}} {pre}cc{post} {{post*R}} + + That is, + 1. Assert pre. That is, check that q |- pre*R. + 2. Compute the post {pre}cc{post'}. + 3. Check that post' |- post. + 4. Assume post. That is, return post*R. + + All subject to: avoiding name clashes, framing, etc. + *) + failwith "SymExec(Generic({p}c{q})) not implemented" + + +let exec_inst cxt {I.desc} = function + | None -> + None + | Some(q) -> + try Some(exec_inst cxt desc q) + with Error -> None + + + +(*============================================================================ + Procedures + ============================================================================*) + +(** Ghosts encapsulates the heuristic for choosing which ghost variables get + existentially quantified in procedure preconditions. *) +module Ghosts : sig + type t + val create : Prog.t -> t + val add_for : t -> Vars.t -> S.t * S.t * Vars.t +end = struct + + type t = Vars.t list ref + + let create _ = ref [] + + (** [add_for t vs = (s,os)] such that [s] renames [vs] to fresh variables + and [os] are variables from [t] that now should be existential. *) + let add_for vsl vs = + let vs_to_gs, gs_to_vs, gs = + Vars.fold (fun v (vs_to_gs, gs_to_vs, gs) -> + let g = Var.gensym (Var.name v) (Var.sort v) in + let g' = Exp.mkVar g in + let v' = Exp.mkVar v in + (S.add v' g' vs_to_gs, S.add g' v' gs_to_vs, Vars.add g gs) + ) vs (S.empty, S.empty, Vars.empty) + in + (* keep the limit_ghosts most recent sets of ghosts *) + let vsl', to_project = + if 0 > Config.limit_ghosts || List.length !vsl < Config.limit_ghosts then + (gs :: !vsl, Vars.empty) + else match List.rev !vsl with + | [] -> + ([], gs) + | last :: vsl_rev -> + (gs :: List.rev vsl_rev, last) + in + if not (Vars.is_empty to_project) then + L.printf 6 "@[losing ghosts: %a@]" Vars.fmt to_project + ; + vsl := vsl' + ; + (vs_to_gs, gs_to_vs, to_project) + +end + + +(* representation state for the symbolic heaps domain *) + +type t = XSH.t option + +let compare = Option.compare XSH.compare +let equal = Option.equal XSH.equal + +let fmt ff q = Option.fmt "ERROR" XSH.fmt ff q + + +type r = Prog.t * Ghosts.t +let create pgm = (pgm, Ghosts.create pgm) + + + +(** For a procedure call \{call\} p(A), [footprint call p A] returns a + subheap of [call] that over-approximates the footprint of the call. *) +let footprint call callee actuals = + if not Config.optimize_frame then (call, XSH.emp) else + Frame.footprint call callee actuals + + + +let call_to_entry (_prog, ghosts) call ({Call.proc; actuals} as pcall) = + let {Proc.formals; freturn; locals} = proc in + match call with + | None -> (None, fun _post -> None) + | Some(call) + -> + (* over-approximate the call's footprint *) + let pre, frame = footprint call proc actuals + in + L.printf 6 "@[footprint:@ %a@]" XSH.fmt pre + ; + (* add ghosts for the shadowed formals and locals *) + let frmls_lcls = + Vars.union (Vars.of_list formals) locals + in + let shdws = + Vars.inter frmls_lcls (Vars.union (Vars.of_list actuals) (XSH.fv pre)) + in + let shdws_to_ghsts, ghsts_to_shdws, olds = Ghosts.add_for ghosts shdws + in + (* rename the shadowed formals and locals *) + let actuals = + List.map (fun a -> + match Exp.desc (S.subst shdws_to_ghsts (Exp.mkVar a)) with + | Exp.Var(v) -> v + | _ -> failwith "frmls_to_actls must be a variable renaming" + ) actuals + in + let pre = XSH.subst shdws_to_ghsts pre + in + L.printf 6 "@[actuals, pre renamed shadowed formals & locals:@ %a@ %a@ %a@]" + S.fmt shdws_to_ghsts (List.fmt ",@ " Var.fmt) actuals XSH.fmt pre + ; + (* existentially quantify the old ghosts *) + let pre = XSH.exists_intro olds pre + in + (* generalize *) + let pre, junk = Abstraction.abstract pre + in + (* add any junk to the frame *) + let frame = if not junk then frame else XSH.Jnk.star frame + in + L.printf 6 "@[pre generalized:@ %a@]" XSH.fmt pre + ; + let frmls_to_actls, _actuals = Call.args pcall in + let actls_to_frmls = S.fold (fun f a s -> S.add a f s) frmls_to_actls S.empty + in + (* express pre in terms of formals *) + let pre = XSH.subst actls_to_frmls pre + in + L.printf 6 "@[pre ito formals:@ %a@ %a@]" S.fmt actls_to_frmls XSH.fmt pre + ; + let frmls_to_actls_n_ghsts_to_shdws = + S.compose frmls_to_actls ghsts_to_shdws + in + let post_to_retn post = + L.printf 5 "@[post:@ %a@]" XSH.fmt post + ; + (* express in terms of actuals and reinstate the shadowed formals and locals *) + L.printf 6 "@[frmls_to_actls: %a@ ghsts_to_shdws: %a@ composition: %a@]" + S.fmt frmls_to_actls S.fmt ghsts_to_shdws S.fmt frmls_to_actls_n_ghsts_to_shdws + ; + let retn = XSH.subst frmls_to_actls_n_ghsts_to_shdws post + in + let retn = XSH.exists_intro (Option.fold Vars.add freturn Vars.empty) retn + in + L.printf 5 "@[post ito actuals & shadows:@ %a@]" XSH.fmt retn + ; + (* reconjoin frame *) + L.printf 6 "@[frame:@ %a@]" XSH.fmt frame + ; + let retn = XSH.star [retn] frame + in + let retn = if Prover.inconsistentx retn then XSH.ff else retn + in + L.printf 5 "@[return:@ %a@\n@]" XSH.fmt retn + ; + retn + in + (Some(pre), Option.map post_to_retn) + + + +let exit_to_retn {Proc.locals} exit = + match exit with + | None -> None + | Some(exit) + -> + L.printf 6 "@[out-scoping locals: @[%a@]@]" Vars.fmt locals; + (* quantify the locals *) + Some(XSH.exists_intro locals exit) + + + +let adapted_pre_substate_call_syntactic _ _cxt pre call ({Call.proc; actuals} as pcall) = +(* Notes: *) + (* - Here we should introduce ghosts just like in _logical, and factor + out common code between _syntactic and _logical. *) + (* - There is redundancy here, call will be abstracted again for every + pre. Reorder the arguments and partially apply in interproc? Also, + after calling abstract here, ATS.widen will also call it on the same + formula. *) + let {Proc.freturn} = proc in + match pre, call with + | None , _ -> Some(fun _post -> None) + | _ , None -> None + | Some(pre), Some(call) + -> + let call, junk = Abstraction.abstract call + in + assert( not junk ) + ; + let foot, frame = footprint call proc actuals + in + L.printf 5 "@[footprint:@ %a@]" XSH.fmt foot + ; +(* let frame = lazy ( *) +(* XSH.emp *) +(* (* Note: For stronger instrumentation, either extend footprint to also *) +(* return the frame, or use subtraction as follows: *) +(* let zs, foot = XSH.exists_bind Vars.empty foot in *) +(* let ws, call = XSH.exists_bind (Vars.diff (SH.fv foot) zs) call in *) +(* (* below we fix zs in foot, so above zs were permitted to appear in call *) *) +(* match Prover.subtract call Vars.empty foot with *) +(* | None -> failwith "SymbolicExecution: footprint unsound" *) +(* | Some(frame,_) -> *) +(* L.printf 5 "@[frame:@ %a@]" XSH.fmt frame *) +(* ; *) +(* XSH.exists_intro ws frame *) *) +(* ) in *) + (* express pre in terms of actuals *) + let frmls_to_actls, _actuals = Call.args pcall in + let pre = XSH.subst frmls_to_actls pre + in + L.printf 6 "@[pre substituted actuals/formals:@ %a@ %a@]" + S.fmt frmls_to_actls XSH.fmt pre + ; + match XSH.equivalent foot pre with + | None -> None + | Some(witnesses) -> + L.printf 6 "@[witnesses:@ %a@]" S.fmt witnesses + ; + (* conjoin witnesses to frame *) + let frame = lazy ( + let frame = XSH.Pf.star [S.to_exp witnesses] frame + in + L.printf 6 "@[frame and witnesses:@ %a@]" XSH.fmt frame + ; + frame + ) in + let post_to_retn post = + L.printf 5 "@[post:@ %a@]" XSH.fmt post + ; + (* express in terms of actuals *) + let post = XSH.subst frmls_to_actls post + in + let post = XSH.exists_intro (Option.fold Vars.add freturn Vars.empty) post + in + L.printf 6 "@[ito actuals:@ %a@ %a@]" S.fmt frmls_to_actls XSH.fmt post + ; + (* reconjoin frame *) + let retn = XSH.star [post] (Lazy.force frame) + in + let retn = if Prover.inconsistentx retn then XSH.ff else retn + in + L.printf 5 "@[post star frame:@ %a@]" XSH.fmt retn + ; + retn + in + Some(Option.map post_to_retn) + + + +let adapted_pre_substate_call_logical ({Prog.globals}, _ghosts) cxt pre call ({Call.proc; actuals} as pcall) = + let {Proc.formals; freturn; modifs} = proc in + match pre, call with + | None , _ -> Some(fun _post -> None) + | _ , None -> None + | Some(pre), Some(call) + -> + L.printf 6 "@[pre:@ %a@]" XSH.fmt pre + ; + let fv_pre = XSH.fv pre in + let fs = Vars.of_list formals + in + let gs = + if Config.optimize_frame then + Vars.diff fv_pre + (Vars.union (Vars.union fs modifs) globals) + else + (* Only vars in the footprint are given ghosts, whether or not procedure + calls are localized, since the prover isn't supposed to be able to + handle the existentials that arise from trying to instantiate ghosts + from outside the footprint. *) + let footprint, _ = Frame.footprint pre proc actuals in + Vars.diff (XSH.fv footprint) + (Vars.union (Vars.union fs modifs) globals) + in + L.printf 6 "@[ghosts:@ [%a]@]" Vars.fmt gs + ; + let post_image vs subst = + Vars.fold (fun v -> Vars.union (Exp.fv (S.subst subst (Exp.mkVar v)))) + vs Vars.empty + in + (* rename ghosts in call and actuals that appear in actuals *) + let frmls_to_actls, _actuals = Call.args pcall in + let fs_appear = Vars.inter fv_pre fs in + let fv_actls = post_image fs_appear frmls_to_actls + in + let call, _, gas_to_gas', gas'_to_gas = + XSH.rename_vs (Vars.inter gs fv_actls) call + in + let frmls_to_actls = S.compose frmls_to_actls gas_to_gas' + in + L.printf 6 "@[call renamed actuals ghosts:@ %a@ %a@]" S.fmt gas_to_gas' XSH.fmt call + ; + (* express pre in terms of actuals *) + let pre = XSH.subst frmls_to_actls pre + in + L.printf 6 "@[pre substituted actuals/formals:@ %a@ %a@]" + S.fmt frmls_to_actls XSH.fmt pre + ; + let global = Config.precondition_order <> Config.WeakerSubheap + in + match exec_gc global cxt call gs pre modifs with + | None -> None + | Some(post_to_retn) -> + let post_to_retn post = + L.printf 5 "@[post:@ %a@]" XSH.fmt post + ; + (* express in terms of actuals *) + let post = XSH.subst frmls_to_actls post + in + let post = XSH.exists_intro (Option.fold Vars.add freturn Vars.empty) post + in + L.printf 6 "@[ito actuals:@ %a@ %a@]" S.fmt frmls_to_actls XSH.fmt post + ; + let retn' = post_to_retn post + in + (* reinstate the shadowed ghosts in actuals *) + let retn = XSH.subst gas'_to_gas retn' + in + L.printf 5 "@[return:@ %a@]" XSH.fmt retn + ; + retn + in + Some(Option.map post_to_retn) + + + +let adapted_pre_substate_call r = + match Config.precondition_order with + | Config.Syntactic -> adapted_pre_substate_call_syntactic r + | _ -> adapted_pre_substate_call_logical r + + + +let rec value_of_ sh exp = + L.incf 100 "( value_of_: %a@ %a" Exp.fmt exp SH.fmt sh ; + L.decf 100 ") value_of_: @[[%a]@]" (fun ff -> function + | None -> () + | Some(is) -> List.fmt ";@ " Format.pp_print_int ff (IntSet.to_list is)) + <& + (* find a value to which sh equates exp *) + match + Exps.fold (fun e value -> + if value <> None then + value + else + match Exp.desc e with + | Exp.Num(i) -> Some(Int64.to_int i) + | _ -> value + ) (SH.Pf.class_of sh exp) None + with + | Some(value) -> + Some(IntSet.singleton value) + | None -> + (* find a disjunction in which each disjunct equates exp *) + SH.DjS.fold (fun dj opt_value -> + if opt_value <> None then + opt_value + else + Dj.fold (fun dt opt_values -> + match opt_values with + | None -> None + | Some(values) -> + match value_of_ dt exp with + | None -> None + | Some(vals) -> Some(IntSet.union vals values) + ) dj (Some(IntSet.empty)) + ) sh None + + +let value_of xsh exp = + let xsh = XSH.normalize xsh in + let _xs, sh = XSH.exists_bind Vars.empty xsh in + value_of_ sh exp + + +let resolve_indirect_call ({Prog.procs}, _ghosts) q loc _ftyp = + L.incf 5 "( resolve_indirect_call: %a@ %a" Exp.fmt loc fmt q ; + L.decf 5 ") resolve_indirect_call: @[[%a]@]" (List.fmt ";@ " Proc.Id.fmt) + <& + match q with + | None -> + [] + | Some(q) -> + (* Note: review using Vars.empty here *) + let cxt = Vars.empty in + let cnt = Var.gensym "cnt" Var.IntegerSort in + let ys = Vars.singleton cnt in + let cnt = Exp.mkVar cnt in + let cxt = Vars.union ys cxt in + try + let _xs, _pt, rem = subtract_field cxt q ys loc (Some(cnt)) in + match value_of rem cnt with + | Some(callee_nums) -> + IntSet.fold (fun callee_num callees -> + let dummy_id = Proc.Id.unsafe_create callee_num "dummy" in + let {Proc.id} = Proc.IdHMap.find procs dummy_id in + id :: callees + ) callee_nums [] + | None -> + [] + with Error -> + [] diff --git a/src/SymbolicExecution.mli b/src/SymbolicExecution.mli new file mode 100644 index 0000000..ae64855 --- /dev/null +++ b/src/SymbolicExecution.mli @@ -0,0 +1,39 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Symbolic Execution of commands on symbolic heaps *) + +open Library + +open Type +open Variable +open Expression +open SymbolicHeap +open Program + +val normalize_tmr : Timer.t + + +(*============================================================================ + SymbolicExecution + ============================================================================*) + +type t = XSH.t option + +val compare : t -> t -> int +val equal : t -> t -> bool +val fmt : t formatter + + +val exec_inst : Vars.t -> Inst.t -> t -> t + +type r + +val create : Prog.t -> r + +val adapted_pre_substate_call : r -> Vars.t -> t -> t -> Proc.t Call.t -> (t -> t) option + +val call_to_entry : r -> t -> Proc.t Call.t -> t * (t -> t) + +val exit_to_retn : Proc.t -> t -> t + +val resolve_indirect_call : r -> t -> Exp.t -> Typ.t -> Proc.Id.t list diff --git a/src/SymbolicHeap.ml b/src/SymbolicHeap.ml new file mode 100644 index 0000000..c7e1ad7 --- /dev/null +++ b/src/SymbolicHeap.ml @@ -0,0 +1,2986 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Symbolic Heap formulas *) + +open Library + +open Type +open Variable +open Expression +module E = Exp +module O = Off +module HC = HashCons +module S = Substitution +open SYMBOLIC_HEAP + +module L = (val Log.std Config.vSH : Log.LOG) + + + +(* Timing =================================================================== *) + +let normalize_tmr = Timer.create "SH.normalize" +let normalize_stem_tmr = Timer.create "SH.normalize_stem" +let exists_elim_tmr = Timer.create "SH.exists_elim" +let pure_consequences_tmr = Timer.create "SH.pure_consequences" +let labeled_pure_consequences_tmr = Timer.create "SH.labeled_pure_consequences" + + + +(*Pt========================================================================== + Points-To formulas + ============================================================================*) + +module Pt = struct + + type t = { loc: Exp.t; off: Off.t; cnt: Exp.t option } + + + let fmtp fxt ff {loc; off; cnt} = + let fmt_loc ff = + if !Config.vSH > 3 then Exp.fmt ff loc else + match O.desc off with + | O.Var(v) -> Format.fprintf ff "%a-%a" (E.fmtp fxt) loc (Var.fmtp fxt) v + | O.Path(_,fs) -> E.fmtp fxt ff (E.mkSubs loc fs) + in + Format.fprintf ff "@[(%t -%a-> %a)@]" + fmt_loc (O.fmtp fxt) off (Option.fmt "-" (E.fmtp fxt)) cnt + + let fmt ff x = fmtp (Vars.empty,Vars.empty) ff x + + let fmt_caml ff {loc; off; cnt} = + Format.fprintf ff "{Pt.loc= %a;@ off= %a;@ cnt= %a}" + E.fmt_caml loc O.fmt_caml off + (Option.fmt "None" (fun ff -> Format.fprintf ff "Some(%a)" E.fmt_caml)) + cnt + + let equal x y = + E.equal x.loc y.loc && O.equal x.off y.off + && Option.equal E.equal x.cnt y.cnt + + let compare x y = + let cmp = E.compare x.loc y.loc in if cmp <> 0 then cmp else + let cmp = O.compare x.off y.off in if cmp <> 0 then cmp else + Option.compare E.compare x.cnt y.cnt + + let fold_exps fn {loc; cnt} z = + E.fold fn loc (Option.fold (E.fold fn) cnt z) + + let map_exps fn {loc; off; cnt} = + {loc= fn loc; off= Off.mk (fn (off :>Exp.t)); cnt= Option.map fn cnt} + + let fv {loc; off; cnt} = + Vars.union (Vars.union + (E.fv loc) (O.fv off)) (Option.option Vars.empty E.fv cnt) + + let may_allocs {loc} = + Exps.singleton loc + +end + +module Pts : sig + + include IndexedSet.S with type elt := Pt.t and type idx := E.t + val may_allocs : t -> Exps.t + +end = struct + + (* Sets of points-tos are represented by sets indexed by the alloc + expression to the Pt.t. Note that normalization ensures that no Pts has + more than one Pt per alloc expression. *) + + include IndexedSet.Make(struct + type t = Pt.t + let equal = Pt.equal + let compare = Pt.compare + type idx = E.t + let index {Pt.loc} = loc + let equal_idx = E.equal + let compare_idx = E.compare + end) + + let may_allocs s = Exps.of_list (keys s) + +end + +module ExpPtsMap = MultiMap.Make (Exp) (struct include Pts type elt = Pt.t end) + + + +(*Params====================================================================== + Formal Parameters of List Segment Patterns + ============================================================================*) + +module Params = + BiEdge.Make (struct + include Var + let fold_exps _ _ z = z + let map_exps _ v = v + let fv v = Vars.singleton v + end) + + + +(*Args======================================================================== + Actual Arguments of List Segment formulas + ============================================================================*) + +module Args = struct + + include BiEdge.Make (struct + include Exp + let fold_exps = fold + let map_exps fn e = fn e + end) + + let fmtp fxt ff {prev; frnt; back; next} = + let args = + if !Config.vSH > 3 then {prev; frnt; back; next} else + let first = function [] -> [] | x::_ -> [x] in + {prev= first prev; frnt= first frnt; back= first back; next= first next} in + fmtp fxt ff args + + (** cycle_eqs (p, f;f', b, n;n') = f=n * f'=n' * b=p *) + let cycle_eqs x = + fold_links (fun (a,d) eql -> E.mkEq a d :: eql) x [] + + let remove dir sub arg = + if dir + then remove_prefix sub arg + else remove_suffix sub arg + +end + + + +(*Patn======================================================================== + List Segment Patterns + ============================================================================*) + +module rec Patn : sig + + type t = private { params: Params.t; body: XSh.t; name: string } + include TERM with type t := t + + val mk : ?name:string -> Params.t -> XSh.t -> t + val instantiate : t -> Args.t -> XSh.t + +end = struct + type t = { params: Params.t; body: XSh.t; name: string } + + + let fmtp fxt ff {params; body; name} = + if name = "" || !Config.vDiscovery > 1 then + Format.fprintf ff "@[(\\%a.@ %a)@]" Params.fmt params (XSh.fmtp fxt) body + else + Format.fprintf ff "%s" name + + let fmt ff = fmtp (Vars.empty,Vars.empty) ff + + let fmt_caml _ _ = failwith "Patn.fmt_caml unimplemented" + + + let equal x y = + x == y || (Params.equal x.params y.params && XSh.equal x.body y.body) + + let compare x y = + if x == y then 0 else + let c = Params.compare x.params y.params in if c <> 0 then c else + XSh.compare x.body y.body + + + let fold_exps _ _ z = z + + let map_exps _ p = p + + + let bv x = Params.fv x.params + + let fv x = Vars.diff (XSh.fv x.body) (bv x) + + + let mk ?(name="") params body = + (* Note: Check this constraint. + (fun ({params; body} as patn) -> assert( + (* All variables in [may_allocs params] must be allocated in the body. + In particular, f->_ * ls(L,k,p,f.u,b.v,n) implies k=0. *) + let _, body = XSh.exists_bind Vars.empty body in + let param_allocs = + List.fold (fun a es -> + Exps.add (CngRel.normalize body.Sh.fcr (E.mkVar a)) es + ) (Params.may_allocs params) Exps.empty in + let body_allocs = Sh.must_allocs body in + Exps.subset param_allocs body_allocs || + failwithf "Patn.mk: may_allocs not allocated: %a" fmt patn )) + <& *) + let body = XSh.normalize body in + {params; body; name} + + + let instantiate patn args = + assert(true$> + L.incf 10 "( Patn.instantiate: %a@ (%a)" fmt patn Args.fmt args ); + (fun xsh -> assert(true$> + L.decf 10 ") Patn.instantiate: %a" XSh.fmt xsh )) + <& + (* substitute arguments for parameters *) + let s = + Args.fold2 (fun x e s -> S.add (E.mkVar x) e s) patn.params args S.empty + in + XSh.subst s patn.body + +end + + + +(*Ls========================================================================== + List Segments + ============================================================================*) + +and Ls : sig + + type t = { pat: Patn.t; len: E.t; arg: Args.t } + include TERM with type t := t + val empty_eqs : t -> E.t list + val may_allocs : t -> E.t list + val fst_alloc : t -> E.t + val direction : t -> E.t -> bool + val split_on_fresh_point : t -> Vars.t * Args.t * Args.t + +end = struct + + type t = { pat: Patn.t; len: E.t; arg: Args.t } + + + (** We write ls(L, k, p, f;f'', b, n;n') for an Ls.t value + (L, k, (p, f;f', b, n;n'), ms) *) + let fmtp fxt ff {pat; len; arg} = + Format.fprintf ff "@[ls(%a,@ %a,@ %a)@]" + (Patn.fmtp fxt) pat (E.fmtp fxt) len (Args.fmtp fxt) arg + + let fmt ff = fmtp (Vars.empty,Vars.empty) ff + + let fmt_caml ff {pat; len; arg} = + Format.fprintf ff "@[{Ls.pat=%a;@ len=%a;@ arg=%a}@]" + Patn.fmt_caml pat E.fmt_caml len Args.fmt_caml arg + + + let equal x y = + Patn.equal x.pat y.pat && E.equal x.len y.len && Args.equal x.arg y.arg + + let compare x y = + let c = Args.compare x.arg y.arg in if c <> 0 then c else + let c = E.compare x.len y.len in if c <> 0 then c else + Patn.compare x.pat y.pat + + + let fold_exps fn {len; arg} z = + E.fold fn len (Args.fold_exps fn arg z) + + let map_exps fn {pat; len; arg} = { + pat= Patn.map_exps fn pat; + len= fn len; + arg= Args.map_exps fn arg; + } + + + let fv {pat; len; arg} = + Vars.union (Vars.union (Patn.fv pat) (E.fv len)) (Args.fv arg) + + + (** empty_eqs ls(L, k, p0, f;f', b0, n;n') = k=0 * f=n * f'=n' * b0=p0 *) + let empty_eqs {len; arg} = + E.mkEq len E.zero :: Args.cycle_eqs arg + + + let may_allocs {arg} = + Args.may_allocs arg + + + let fst_alloc ({arg= {frnt; back}} as ls) = + match frnt, back with + | f :: _, _ -> f + | [], b :: _ -> b + | [], [] -> + (* Note: Enforce this requirement with a constructor? *) + invalid_argf "Ls.fst_alloc: list must have at least one end: %a" + fmt ls + + + let direction {arg={frnt; back}} loc = + (fun dir -> assert( dir || List.exists (fun a -> E.equal loc a) back )) + <& + List.exists (fun a -> E.equal loc a) frnt + + + let split_on_fresh_point {pat= {Patn.params= {frnt; back}}; arg} = + let freshen params vs = + List.fold (fun param (vl,vs) -> + let v = Var.gensym (Var.name param) (Var.sort param) in + (E.mkVar v :: vl, Vars.add v vs) + ) params ([],vs) + in + let fs, vs = freshen frnt Vars.empty in + let bs, vs = freshen back vs in + let fnt, bck = Args.split bs fs arg in + (vs, fnt, bck) + +end + +and Lss : sig + + include MultiIndexedSet.S with type elt := Ls.t and type idx := E.t + val may_allocs : t -> Exps.t + +end = struct + + (* Sets of list segments are represented by sets of ls formulas indexed by + _every_ may alloc expression in the ls formula. Note that normalization + ensures that no Lss has more than one Ls per may alloc expression. *) + + include MultiIndexedSet.Make(struct + type t = Ls.t + let equal = Ls.equal + let compare = Ls.compare + type idx = E.t + let index = Ls.fst_alloc + let indices = Ls.may_allocs + let equal_idx = E.equal + let compare_idx = E.compare + end) + + let may_allocs s = Exps.of_list (keys s) + +end + +and LsB : sig + + include MultiIndexedMultiSet.S with type idx := E.t and type elt := Ls.t and type elts = Ls.t list + +end = struct + + module IndexedLs = struct + type t = Ls.t + let equal = Ls.equal + let compare = Ls.compare + type idx = E.t + let index = Ls.fst_alloc + let indices = Ls.may_allocs + let equal_idx = E.equal + let compare_idx = E.compare + end + include MultiIndexedMultiSet.Make (IndexedLs) (List.Set(Ls)) + +end + + + +(*Dj========================================================================== + Disjunctions + ============================================================================*) + +and ShSet : (Set.S with type elt := Sh.t) = Set.Make(Sh) + +(* disjunctions of symbolic heaps *) +and Dj : sig + + include TERM with type t = ShSet.t + val fv : ?include_cng_rels:bool -> t -> Vars.t + val may_allocs : t -> Exps.t + include Set.S with type elt := Sh.t and type t := t + val fold_commutative_semigroup : ('z -> 'z -> 'z) -> (Sh.t -> 'z) -> t -> 'z +(* val may_allocs : t -> Exps.t *) + val fmtsp : Sh.t -> Var.fxt -> t formatter + +end = struct + open Sh_t + + (* Disjunctions are represented by sets of Sh formulas, normalized with + respect to identify of ff \/ -, associativity of \/, and equivalence of + boolean and symbolic heap disjunction on pure formulas. *) + + include ShSet + + let fmtsp sup fxt ff x = + let dts = to_list x in + let compare_by_lbl x y = let o = Pervasives.compare x.lbl y.lbl in if o<>0 then o else Sh.compare x y in + let dts = List.sort compare_by_lbl dts in + Format.fprintf ff "@[{ %a }@]" + (List.fmt " \\/@ " (Sh.fmtsp sup fxt)) dts + + let fmtp fxt = fmtsp (Sh.emp()) fxt + + let fmt ff = fmtp (Vars.empty,Vars.empty) ff + + let fmt_caml ff x = + Format.fprintf ff "@[(Dj.of_list@ [@[%a@]]@])" + (List.fmt ";@ " Sh.fmt_caml) (to_list x) + + let fv ?(include_cng_rels=true) s = + fold (fun q vs -> Vars.union (Sh.fv ~include_cng_rels q) vs) s Vars.empty + + let map_exps fn dj = map (Sh.map_exps fn) dj + + let fold_exps fn = fold (Sh.fold_exps fn) + +(* let map_foldi fn (s,z) = *) +(* foldi (fun i q (s,z) -> *) +(* let q',z' = fn i (q,z) in *) +(* (add q' s, z') *) +(* ) s (empty,z) *) + + (* if the image of Dj.t under fn is a commutative semigroup with + operation mul, then multiply the image of dj under fn *) + let fold_commutative_semigroup mul fn dj = + let q = choose dj in (* dj must have at least one disjunct *) + let qs = remove q dj in + fold (fun r -> mul (fn r)) qs (fn q) + + let may_allocs s = + fold (fun sh es -> Exps.union (Sh.may_allocs sh) es) s Exps.empty + +end + +(* *-conjunctions of disjunctions of symbolic heaps *) +and Djs : sig + + include Set.S with type elt := Dj.t + val fold_semiring : ('z->'z->'z) -> ('z->'z->'z) -> (Sh.t->'z) -> t -> 'z->'z + +end = struct + include Set.Make(Dj) + +(* let map fn s = *) +(* L.incf 0 "( Djs.map" ; (fun _ -> L.decf 0 ") Djs.map") <& *) +(* map fn s *) + + (* if the image of Dj.t under fn is a semiring with operations add and mul, + then sum the products of the image of each disjunct under fn *) + let fold_semiring add mul fn = + fold (fun dj -> add (Dj.fold_commutative_semigroup mul fn dj)) + +end + + + +(*F=========================================================================== + subFormulas + ============================================================================*) + +and F : (sig + include TERM with type t = Sh_t.f + val fv : ?include_cng_rels:bool -> t -> Vars.t + val may_allocs : t -> Exps.t + val fmtsp : Sh.t -> Var.fxt -> t formatter +end) = struct + + open Sh_t + + type t = f + + let fv ?(include_cng_rels=true) = function + | Pt(x) -> Pt.fv x + | Ls(x) -> Ls.fv x + | Dj(x) -> Dj.fv ~include_cng_rels x + + let may_allocs = function + | Pt(x) -> Pt.may_allocs x + | Ls(x) -> Exps.of_list (Ls.may_allocs x) + | Dj(x) -> Dj.may_allocs x + + let map_exps fn = function + | Pt(x) -> Pt(Pt.map_exps fn x) + | Ls(x) -> Ls(Ls.map_exps fn x) + | Dj(x) -> Dj(Dj.map_exps fn x) + + let fold_exps fn a z = + match a with + | Pt(x) -> Pt.fold_exps fn x z + | Ls(x) -> Ls.fold_exps fn x z + | Dj(x) -> Dj.fold_exps fn x z + + let compare x y = + match x, y with + | Pt(x), Pt(y) -> Pt.compare x y + | Ls(x), Ls(y) -> Ls.compare x y + | Dj(x), Dj(y) -> Dj.compare x y + | (Pt _ | Ls _ | Dj _), _ -> Pervasives.compare x y + + let equal x y = + match x, y with + | Pt(x), Pt(y) -> Pt.equal x y + | Ls(x), Ls(y) -> Ls.equal x y + | Dj(x), Dj(y) -> Dj.equal x y + | (Pt _ | Ls _ | Dj _), _ -> false + + let fmtsp sup fxt ff = function + | Pt(x) -> Pt.fmtp fxt ff x + | Ls(x) -> Ls.fmtp fxt ff x + | Dj(x) -> Dj.fmtsp sup fxt ff x + + let fmtp fxt = fmtsp (Sh.emp()) fxt + + let fmt ff = fmtp (Vars.empty,Vars.empty) ff + + let fmt_caml ff = function + | Pt(x) -> Pt.fmt_caml ff x + | Ls(x) -> Ls.fmt_caml ff x + | Dj(x) -> Dj.fmt_caml ff x + +end + + +and Fs : sig + + type t = { p: Pts.t; l: Lss.t; d: Djs.t } + + val empty : t + val is_empty : t -> bool + val is_empty_djs : t -> bool + val is_empty_pts_lss : t -> bool + val singleton : F.t -> t + val add : F.t -> t -> t + val remove : F.t -> t -> t + val union : t -> t -> t +(* val of_list : F.t list -> t *) + val to_list : t -> F.t list + val fold : (F.t -> 'z -> 'z) -> t -> 'z -> 'z + val clear_pts : t -> t + val clear_lss : t -> t + val clear_djs : t -> t + val only_djs : t -> t + val fold_pts : (Pt.t -> 'z -> 'z) -> t -> 'z -> 'z + val fold_lss : (Ls.t -> 'z -> 'z) -> t -> 'z -> 'z + val fold_djs : (Dj.t -> 'z -> 'z) -> t -> 'z -> 'z + val exists_djs : (Dj.t -> bool) -> t -> bool + val forall_djs : (Dj.t -> bool) -> t -> bool + val trytake_djs : (Dj.t -> bool) -> t -> Dj.t option +(* val extract_djs : t -> Dj.t * t *) + val tryextract_djs : t -> (Dj.t * t) option + val map_djs : (Dj.t -> Dj.t) -> t -> t + val map_fold_djs : (Dj.t * 'z -> Dj.t * 'z) -> t * 'z -> t * 'z + val extract_all_djs : t -> t * t + val partition : (F.t -> bool) -> t -> t * t + val map : (F.t -> F.t) -> t -> t +(* val map_filter : (F.t -> F.t option) -> t -> t *) + val fold_filter : (F.t -> 'z -> 'z option) -> t -> 'z -> t * 'z + val find : E.t -> t -> F.t + val tryfind : E.t -> t -> F.t option + val may_allocs : t -> Exps.t + val diff_inter_diff : t -> t -> t * t * t +(* val fold_exps : (E.t -> 'z -> 'z) -> t -> 'z -> 'z *) + val equal : t -> t -> bool + val compare : t -> t -> int +(* val mem : F.t -> t -> bool *) + +end = struct + + (* Note: Revise this implementation to include a (partial?) order on f's + for the purpose of expressing quantifier guarding, changing all the + operations that enumerate f's to obey the order, and adding operations to + dynamically change the order. *) + + open Sh_t + + type t = { p: Pts.t; l: Lss.t; d: Djs.t } + + let empty = { p= Pts.empty; l= Lss.empty; d= Djs.empty } + + let is_empty {p; l; d} = + Pts.is_empty p && Lss.is_empty l && Djs.is_empty d + + let is_empty_pts_lss {p; l} = + Pts.is_empty p && Lss.is_empty l + + let singleton = function + | Pt(pt) -> {empty with p= Pts.singleton pt} + | Ls(ls) -> {empty with l= Lss.singleton ls} + | Dj(dj) -> {empty with d= Djs.singleton dj} + + let union x y = { + p= Pts.union x.p y.p; + l= Lss.union x.l y.l; + d= Djs.union x.d y.d; + } + + let add x fs = + match x with + | Pt(pt) -> {fs with p= Pts.add pt fs.p} + | Ls(ls) -> {fs with l= Lss.add ls fs.l} + | Dj(dj) -> {fs with d= Djs.add dj fs.d} + + let remove x fs = + match x with + | Pt(pt) -> {fs with p= Pts.remove pt fs.p} + | Ls(ls) -> {fs with l= Lss.remove ls fs.l} + | Dj(dj) -> {fs with d= Djs.remove dj fs.d} + +(* let mem x fs = *) +(* match x with *) +(* | Pt(pt) -> Pts.mem pt fs.p *) +(* | Ls(ls) -> Lss.mem ls fs.l *) +(* | Dj(dj) -> Djs.mem dj fs.d *) + + let fold fn {p; l; d} z = + Djs.fold (fun dj z -> fn (Dj(dj)) z) d + (Lss.fold (fun ls z -> fn (Ls(ls)) z) l + (Pts.fold (fun pt z -> fn (Pt(pt)) z) p z)) + + let map fn x = + fold (fun f z -> add (fn f) z) empty x + +(* let fold_exps fn {p; l; d} z = *) +(* Djs.fold (fun dj z -> Dj.fold_exps fn dj z) d *) +(* (Lss.fold (fun ls z -> Ls.fold_exps fn ls z) l *) +(* (Pts.fold (fun pt z -> Pt.fold_exps fn pt z) p z)) *) + + let clear_pts fs = {fs with p= empty.p} + let clear_lss fs = {fs with l= empty.l} + let clear_djs fs = {fs with d= empty.d} + let only_djs fs = {fs with p= empty.p; l= empty.l} + + let fold_pts fn fs z = Pts.fold fn fs.p z + let fold_lss fn fs z = Lss.fold fn fs.l z + let fold_djs fn fs z = Djs.fold fn fs.d z + + let exists_djs fn fs = Djs.exists fn fs.d + let forall_djs fn fs = Djs.for_all fn fs.d + let trytake_djs fn fs = Djs.trytake fn fs.d +(* let extract_djs fs = let dj,d = Djs.extract fs.d in (dj, {fs with d}) *) + let tryextract_djs fs = match Djs.tryextract fs.d with Some(dj,d) -> Some(dj, {fs with d}) | None -> None + let is_empty_djs fs = Djs.is_empty fs.d + + let map_djs fn fs = {fs with d= Djs.map fn fs.d} + + let extract_all_djs fs = ({fs with d= empty.d}, {empty with d= fs.d}) + + let map_fold_djs fn (fs, z) = + let d, z = Djs.map_fold fn (fs.d, z) in + ({fs with d}, z) + +(* let fold_filter fn xs z = *) +(* let rec loop rys xs z = *) +(* match xs with *) +(* | [] -> (List.rev rys, z) *) +(* | x :: xs -> *) +(* match fn x z with *) +(* | None -> loop (x :: rys) xs z *) +(* | Some(z') -> loop rys xs z' *) +(* in *) +(* loop [] xs z *) + + let partition fn fs = + fold (fun f (ts,fs) -> + if fn f then (add f ts, fs) else (ts, add f fs) + ) fs (empty, empty) + +(* let map_filter fn fs = *) +(* fold (fun f fs -> *) +(* match fn f with *) +(* | None -> fs *) +(* | Some(f') -> add f' fs *) +(* ) fs empty *) + + let fold_filter fn fs z = + fold (fun f (fs, z) -> + match fn f z with + | None -> (fs, z) + | Some(z') -> (remove f fs, z') + ) fs (fs, z) + +(* let of_list fl = List.fold add fl empty *) + let to_list fs = fold List.cons fs [] + + let find e fs = + try Pt(Pts.find e fs.p) with Not_found -> Ls(Lss.find e fs.l) + + let tryfind e fs = + try Some(find e fs) with Not_found -> None + + + let rec may_allocs fs = + Djs.fold (fun dj es -> + Dj.fold (fun dt es -> + Exps.union (may_allocs dt.sfs) es + ) dj es + ) fs.d (Exps.union (Pts.may_allocs fs.p) (Lss.may_allocs fs.l)) + + let diff_inter_diff q r = + let q_r_pts, int_pts, r_q_pts = Pts.diff_inter_diff q.p r.p + and q_r_lss, int_lss, r_q_lss = Lss.diff_inter_diff q.l r.l + and q_r_djs, int_djs, r_q_djs = Djs.diff_inter_diff q.d r.d + in + let q_r = {p= q_r_pts; l= q_r_lss; d= q_r_djs} + and int = {p= int_pts; l= int_lss; d= int_djs} + and r_q = {p= r_q_pts; l= r_q_lss; d= r_q_djs} + in + (q_r, int, r_q) + + let equal p q = + Pts.equal p.p q.p + && Lss.equal p.l q.l + && Djs.equal p.d q.d + + let compare p q = + let o = Pts.compare p.p q.p in if o <> 0 then o else + let o = Lss.compare p.l q.l in if o <> 0 then o else + Djs.compare p.d q.d + +end + + + +(*Sh========================================================================== + (quantifier-free) Symbolic Heap formulas + ============================================================================*) + +and Sh_t : sig + + type f = Pt of Pt.t | Ls of Ls.t | Dj of Dj.t + + type t = { + lbl: int; (** label identifies unique point in *-v tree *) + fcr: CngRel.t; (** full congruence relation *) + tcr: CngRel.t; (** trimmed congruence relation *) + pas: Exps.t; (** pure subformulas *) + sfs: Fs.t; (** spatial subformulas *) + jnk: bool; (** arbitrary "junk" heap subformula *) + } + + type vs_t = Vars.t * t + +end = Sh_t (* Contains only type definitions, so can be vacuously defined. *) + + +and Sh : sig + include + (QUANTIFIER_FREE_SYMBOLIC_HEAP + with type t = Sh_t.t and type xsh := XSh.t + and type pt := Pt.t and type ls := Ls.t and type dj := Dj.t) + + (* internal operations *) + val fmtsp : t -> Var.fxt -> t formatter +(* val is_disjunction : t -> bool *) + val renaming : Vars.t -> Vars.t * S.t * S.t +(* val rep_cmp : Exps.t -> Vars.t -> E.t -> E.t -> int *) + + (* shadow ground values that cannot be exported from recursive module *) + val emp : unit -> t + val tt : unit -> t + val ff : unit -> t + +end = struct + + include Sh_t + + + (* Base Constructors ====================================================== *) + + let emp = { + lbl= 0; + fcr= CngRel.empty; + tcr= CngRel.empty; + pas= Exps.empty; + sfs= Fs.empty; + jnk= false; + } + + let tt = {emp with jnk= true} + + let ff = {tt with pas= Exps.singleton E.ff; jnk= false} + + let dj_empty = Dj.of_list [] + + let rec clear_cng sh = + let sfs = Fs.map_djs (fun dj -> Dj.map clear_cng dj) sh.sfs in + {sh with fcr= emp.fcr; tcr= emp.tcr; sfs} + + + + (* Folds ================================================================== *) + + let rec fold fn sh z = + let z = + Fs.fold_djs (fun dj z -> + Dj.fold (fun dt z -> + fold fn dt z + ) dj z + ) sh.sfs z in + fn sh z + + + let rec fold_sp dn up sh sa pa = +(* L.incf 0 "( SH.fold_sp: %a" Sh.fmt sh ; *) +(* L.decf 0 ") SH.fold_sp%a" (fun _ _ -> ()) <& *) + let sa = dn sh sa in + let pa = + Fs.fold_djs (fun dj pa -> + Dj.fold (fun dt pa -> + fold_sp dn up dt sa pa + ) dj pa + ) sh.sfs pa in + up sh sa pa + + + let fold_fs fn sh z = fold (fun {sfs} z -> Fs.fold fn sfs z) sh z + + let fold_exps fn sh z = + fold_fs (fun f z -> F.fold_exps fn f z) sh + (Exps.fold (fun pa z -> E.fold fn pa z) sh.pas z) + + + (* Note: Change to split cases based on list lengths? *) + let fold_dnf ?(dnf=true) map red sh ca da = + if not dnf then + fold_sp map (fun _dt (c,_d) d -> red (c,d)) sh (ca,da) da + else +(* L.incf 4 "( SH.fold_dnf: %a" Sh.fmt sh ; *) +(* L.decf 4 ") SH.fold_dnf%a" (fun _ _ -> ()) <& *) + (* - pending_splits is a disjunction list of case splits which have yet + to be made (none of their disjuncts are in cube_prefix) + - dt is a disjunct in sh which is not represented by cube_prefix or + pending_splits + - ca is the result of applying map to the *-conjuncts in cube_prefix *) + let rec add_disjunct pending_splits dt (ca,da) = +(* L.incf 4 "( add_disjunct: @[[@[%a@]]@ %a@]" (List.fmt ";@ " Dj.fmt) pending_splits Sh.fmt dt ; *) +(* L.decf 4 ") add_disjunct%a" (fun _ _ -> ()) <& *) + split_case + (Fs.fold_djs List.cons dt.sfs pending_splits) + (map dt (ca,da)) + and split_case pending_splits (ca,da) = +(* L.incf 4 "( split_case: [@[%a@]]" (List.fmt ";@ " Dj.fmt) pending_splits ; *) +(* L.decf 4 ") split_case%a" (fun _ _ -> ()) <& *) + match pending_splits with + | dj :: pending_splits -> + Dj.fold (fun dt da -> add_disjunct pending_splits dt (ca,da)) dj da + | [] -> + red (ca,da) + in + add_disjunct [] sh (ca,da) + +(* let fold_dnf map red sh ca da = debug_wrap5 Config.vSH 4 fold_dnf map red sh ca da *) + + + + (* Syntactic Operations =================================================== *) + + let equal p q = + p == q || + (p.jnk = q.jnk && Exps.equal p.pas q.pas && Fs.equal p.sfs q.sfs) + + let compare p q = + if p == q then 0 else + let o = Pervasives.compare p.jnk q.jnk in if o <> 0 then o else + let o = Exps.compare p.pas q.pas in if o <> 0 then o else + Fs.compare p.sfs q.sfs + + + let inconsistent q = Exps.mem E.ff q.pas + + + (** syntactic *-conjunction *) + let syntactic_star p q = + { q with + pas= Exps.union p.pas q.pas; + sfs= Fs.union p.sfs q.sfs; + jnk= p.jnk || q.jnk; + } + + + let partition fn q = + let ts, fs = Fs.partition fn q.sfs in + ({ q with sfs= ts }, { q with sfs= fs }) + + + (** syntactic intersection and differences. + if [diff_inter_diff q r] = [(q_i,i,r_i)] then [union q r] = + [union q_i (union i r_i)] *) + let diff_inter_diff ?(pas=true) q r = + let q_r_pas, int_pas, r_q_pas = if pas then Exps.diff_inter_diff q.pas r.pas else (q.pas, emp.pas, r.pas) + and q_r_fs, int_fs, r_q_fs = Fs.diff_inter_diff q.sfs r.sfs + and q_r_jnk, int_jnk, r_q_jnk = (q.jnk && not r.jnk, q.jnk && r.jnk, r.jnk && not q.jnk) + in + let i = emp in + let q_r = {q with pas= q_r_pas; sfs= q_r_fs; jnk= q_r_jnk} + and int = {i with pas= int_pas; sfs= int_fs; jnk= int_jnk} + and r_q = {r with pas= r_q_pas; sfs= r_q_fs; jnk= r_q_jnk} + in + (q_r, int, r_q) + + let deep_diff_inter_diff sh0 sh1 = + let m0 = fold (fun dt m0 -> IntMap.add dt.lbl dt m0) sh0 IntMap.empty in + let m1 = fold (fun dt m1 -> IntMap.add dt.lbl dt m1) sh1 IntMap.empty in + let m = + IntMap.fold (fun lbl dt0 m -> + let dt1 = try IntMap.find lbl m1 with Not_found -> emp in + let dt0 = {dt0 with sfs= Fs.clear_djs dt0.sfs} in + let dt1 = {dt1 with sfs= Fs.clear_djs dt1.sfs} in + let did = diff_inter_diff dt0 dt1 in + IntMap.add lbl did m + ) m0 IntMap.empty in + let replace_stem prj dt = + let stem = try prj (IntMap.find dt.lbl m) with Not_found -> emp in + let sfs = Fs.fold_djs (fun dj sh -> Fs.add (Dj(dj)) sh) dt.sfs stem.sfs in + {stem with sfs} + in + let o = Sh.map (fun dt -> replace_stem fst3 dt) sh0 in + let i = Sh.map (fun dt -> replace_stem snd3 dt) sh0 in + let n = Sh.map (fun dt -> replace_stem thd3 dt) sh1 in + (o,i,n) + + + let find e q = Fs.find e q.sfs + + let tryfind e q = Fs.tryfind e q.sfs + + let is_empty sh = + let rec loop sh = + not sh.jnk + && Fs.is_empty_pts_lss sh.sfs + && Fs.forall_djs (Dj.for_all loop) sh.sfs + in + loop sh + + let is_pure sh = + let rec loop sh = + Fs.is_empty_pts_lss sh.sfs + && Fs.forall_djs (Dj.for_all loop) sh.sfs + in + sh.jnk && loop sh +(* + let is_disjunction sh = + E.equal E.tt sh.bex + && is_empty { sh with djs= Djs.empty } + && Djs.cardinal sh.djs = 1 +*) + + (* Very crude [sizeof(q)]: add one for each pt, ls and dj. *) + (* Should use [max] for Djs "alternatives", though + is sound. *) +(* let sizeof sh = *) +(* let incr _ x = x + 1 in *) +(* let incr' = { v_b= (fun _ x -> x); v_dj= incr; v_pt= incr; v_ls= incr } in *) +(* fold incr' sh 0 *) + let sizeof sh = + let rec loop sh n = + Fs.fold (fun f n -> + match f with + | Dj(dj) -> Dj.fold loop dj n + | _ -> succ n + ) sh.sfs n + in loop sh 0 + + + let may_allocs_stem q = + Fs.fold (fun f mas -> + match f with + | Pt({Pt.loc}) -> Exps.add loc mas + | Ls(ls) -> List.fold Exps.add (Ls.may_allocs ls) mas + | Dj _ -> mas + ) q.sfs Exps.empty + + let may_allocs q = + Fs.may_allocs q.sfs + + let fv ?(include_cng_rels=true) sh = + fold_fs (fun f vs -> Vars.union (F.fv ~include_cng_rels f) vs) sh + (Exps.fold (fun pa vs -> Vars.union (E.fv pa) vs) sh.pas + (if include_cng_rels then + Exps.fold (fun e vs -> Vars.union (E.fv e) vs) + (CngRel.carrier sh.fcr) Vars.empty + else + Vars.empty)) + + + let count_occurrences sh = + let occ_exp e occ m = +(* L.printf 0 "occ_exp: %a" E.fmt e; *) + let dn e occ = + match E.desc e with + | E.Var _ -> occ + | _ -> Some(e) + in + let up e occ m = + match E.desc e with + | E.Var(x) -> + (match occ with + | Some(sup) when E.equal sup e -> m (* not proper subexp *) + | _ -> VarMap.add x (try VarMap.find x m + 1 with Not_found -> 1) m + ) + | _ -> m + in + E.fold_sp dn up e occ m + in + Exps.fold (fun e m -> + occ_exp e (Some(e)) m + ) sh.pas + (fold_fs (fun f m -> +(* L.printf 0 "occ: %a" F.fmt f; *) + match f with + | Pt({Pt.loc; cnt}) -> + (* Note: Is ignoring off correct? *) + occ_exp loc None (Option.fold (fun e m -> occ_exp e None m) cnt m) + | Ls({Ls.len; arg}) -> + occ_exp len None + (Args.fold_links (fun (a,d) m -> + occ_exp a None (occ_exp d None m) + ) arg m) + | Dj(_) -> + m + ) sh + VarMap.empty) + + + + (* Formatting ============================================================= *) + + let mk_fxt (xs,sh) = + let exists = xs in + let uniques = + Vars.inter exists + (VarMap.fold (fun v n uniques -> + if n <= 1 then Vars.add v uniques else uniques + ) (count_occurrences sh) Vars.empty) in + (exists, uniques) + + + let fmtsp sup fxt ff q = + let tfclss = + CngRel.fold_classes (fun rep fcls clss -> + let tcls = CngRel.class_of q.tcr rep in + if !Config.vSH > 3 then (rep, Exps.remove rep tcls, Exps.remove rep fcls) :: clss else + let fcls = + let partns = + List.classify (fun d e -> + match E.desc d, E.desc e with + | E.App(f,_), E.App(g,_) -> E.equal f g + | _ -> false + ) (Exps.to_list fcls) in + List.fold (fun partn fcls -> + if List.mem rep partn then + Exps.add rep fcls + else + Exps.add (List.hd partn) fcls + ) partns Exps.empty in + let tcls, fcls = Exps.inter_diff fcls tcls in + let tcls = Exps.diff tcls (CngRel.class_of sup.tcr rep) in + let fcls = Exps.diff fcls (CngRel.class_of sup.fcr rep) in + let fcls = + Exps.fold (fun e fcls -> + Exps.diff fcls (CngRel.class_of sup.fcr e) + ) tcls fcls in + let tcls = Exps.remove rep tcls in + if Exps.is_empty fcls && Exps.is_empty tcls then clss else + (rep, tcls, fcls) :: clss + ) q.fcr [] + in + let fmt_cngrels ff = + Format.fprintf ff "@[%a@ %a@]@\n" CngRel.fmt q.fcr CngRel.fmt q.tcr + in + let fmt_cng ff = + let fmt_cls ff cls = + List.fmt " =@ " (Exp.fmtp fxt) ff cls + in + let fmt_fcls ff fcls = + if not (Exps.is_empty fcls) then + Format.fprintf ff " =@ %a" fmt_cls (Exps.to_list fcls) + in + let fmt_tfcls ff (rep,tcls,fcls) = + Format.fprintf ff "@[((%a)%a)@]" + fmt_cls (rep :: (Exps.to_list tcls)) fmt_fcls fcls + in + Format.fprintf ff "@[%a@]" (List.fmt " *@ " fmt_tfcls) (List.rev tfclss) + in + let rep e = Sh.Pf.normalize q e in + let pas = + if !Config.vSH > 3 then q.pas else + Exps.fold (fun pa pas -> + let pa = E.map rep pa in + if E.equal E.tt pa then pas else Exps.add pa pas + ) q.pas Exps.empty + and sfs = + if !Config.vSH > 3 then q.sfs else + try + Fs.map (fun f -> + match f with + | Dj _ -> f + | _ -> F.map_exps rep f + ) q.sfs + with Invalid_argument _ -> + q.sfs (* normalize might violate uniqueness of must allocs *) + in + (* group points-tos for the same base location together, and remove them from sfs *) + let objs, sfs = + if !Config.vSH > 3 then (ExpPtsMap.empty, sfs) else + Fs.fold_pts (fun ({Pt.loc; off} as pt) (objs, sfs) -> + match O.desc off with + | O.Var _ -> + (objs, sfs) + | O.Path(_,fs) -> + let base = E.mkSubs loc fs in + let q = Sh.Pf.extend Vars.empty q base in + let base' = Sh.Pf.normalize q base in + (ExpPtsMap.add base' pt objs, Fs.remove (Pt(pt)) sfs) + ) sfs (ExpPtsMap.empty, sfs) + in + let objs = + ExpPtsMap.fold_keys (fun base pts objs -> + let ty_fs_cnts = + Pts.fold (fun {Pt.off; cnt} ty_fs_cnts -> + match O.desc off with + | O.Path(ty,fs) -> + let rec loop ty fs = + let find ty fs = + let rec find_ gs = + match gs with + | g :: gs -> + (try + loop ty (g :: fs) + with Not_found -> + find_ gs + ) + | [] -> + raise Not_found + in + find_ (Typ.fst_flds ty) + in + match fs with + | (f :: fs) as ffs -> + (match Typ.of_fld ty f with + | Some(fty) -> + (match fs with + | [] -> + (match Typ.fst_flds fty with + | [] -> + ffs + | g :: _ -> + f :: (loop fty [g]) + ) + | _ -> + f :: (loop fty fs) + ) + | None -> + find ty ffs + ) + | [] -> + [] + in + let fs' = List.rev fs in + let fs' = + try loop ty fs' + with Not_found -> + let module L = (val Log.std Config.vTyp : Log.LOG) in + L.shift_verb (!Config.vTyp - 2) (fun () -> + L.printf 0 "@[no path @[%a@]@ in type@ %a@]" (List.fmt ";@ " Fld.fmt) fs' Typ.fmt ty ); + fs' + in + (ty, fs', cnt) :: ty_fs_cnts + | _ -> failwith "unexpected offset" + ) pts [] + in + let ty_fs_cnts = List.sort (fun (_,n,_) (_,o,_) -> List.compare Fld.compare n o) ty_fs_cnts + in + (base, ty_fs_cnts) :: objs + ) objs [] + in + let fmt_objs ff = + let fmt_obj ff (base, ty_fs_cnts) = + let rec fmt_ptl ff ty_fs_cnts = + match ty_fs_cnts with + | [(ty,fs,cnt)] -> + let off = O.mkPath ty (List.rev fs) in + Format.fprintf ff "@[%a:@ %a@]" (O.fmtp fxt) off (Option.fmt "-" (E.fmtp fxt)) cnt + | (_,f::_,_) :: _ -> + Format.fprintf ff "@[%a.@;<0 2>@[%a@]@]" Fld.fmt f fmt_ptll + (List.rev_map (fun (ty,fs,cnt) -> + match fs with + | f :: fs -> (Option.get (Typ.of_fld ty f), fs, cnt) + | [] -> (ty, fs, cnt) + ) ty_fs_cnts) + | _ -> + assert false + and fmt_ptll ff ty_fs_cnts = + Format.fprintf ff "[@[%a@]]" (List.fmt ";@ " fmt_ptl) + (List.classify (fun (_,n,_) (_,o,_) -> + match n, o with + | f::_, g::_ -> Fld.equal f g + | _ -> false + ) ty_fs_cnts) + in + Format.fprintf ff "@[(%a ->@ @[%a@])@]" (E.fmtp fxt) base fmt_ptll ty_fs_cnts + in + Format.fprintf ff "@[%a@]" (List.fmt " *@ " fmt_obj) (List.rev objs) + in + let fmt_pas ff = + List.fmt " *@ " (E.fmtp fxt) ff (Exps.to_list pas) + in + let fmt_sfs ff = + List.fmt " *@ " (F.fmtsp q fxt) ff (List.rev (Fs.to_list sfs)) + in + let fmt_jnk ff = + Format.fprintf ff "true" + in + let fmt_emp ff = + Format.fprintf ff "emp" + in + let fmtl = + let fmtl = + ( (if !Config.vSH > 30 then [fmt_cngrels] else []) + @ (if tfclss = [] then [] else [fmt_cng]) + @ (if Exps.is_empty pas then [] else [fmt_pas]) + @ (if objs = [] then [] else [fmt_objs]) + @ (if Fs.is_empty sfs then [] else [fmt_sfs]) + @ (if q.jnk then [fmt_jnk] else []) ) + in if fmtl = [] then [fmt_emp] else fmtl + in + Format.fprintf ff "@[%i[ @[%a@] ]@]" q.lbl (List.fmtt " *@ ") fmtl + + let fmtp fxt ff q = + let q = if !Config.vSH > 0 then q else snd (Sh.normalize (Vars.empty,q)) in + fmtsp emp fxt ff q + + let fmt ff = fmtp (Vars.empty,Vars.empty) ff + + let fmtsp_xs super ((ys,_) as fxt) ff (xs,sh) = + let xs, sh = if !Config.vSH > 0 then (xs,sh) else Sh.normalize (xs,sh) in + let xs = Vars.union xs ys in + let xs = if !Config.vSH > 0 then xs else Vars.inter xs (fv sh) in + let fxt = if !Config.vSH > 0 then (Vars.empty, Vars.empty) else fxt in + let uniques,_ = fxt in + Format.fprintf ff "@[{ %a@[%a@] }@]" + (Vars.fmtp_embrace "@[? " " .@]@ " fxt) (Vars.diff xs uniques) + (fmtsp super fxt) sh + + let fmtp_xs fxt ff = fmtsp_xs emp fxt ff + let fmt_xs ff = fmtp_xs (Vars.empty,Vars.empty) ff + + let fmt_did_xs ((xs,sh), (xs',sh')) = + let o_sh, i_sh, n_sh = deep_diff_inter_diff sh sh' in + let o_xs, i_xs, n_xs = Vars.diff_inter_diff xs xs' in + let fxt = (xs , Vars.empty) in + let fxt' = (xs', Vars.empty) in + ( (fun ff -> fmtsp_xs i_sh fxt ff (o_xs, o_sh)) + , (fun ff -> fmtsp_xs i_sh fxt' ff (i_xs, i_sh)) + , (fun ff -> fmtsp_xs i_sh fxt' ff (n_xs, n_sh)) + ) + + let fmt_did (sh, sh') = fmt_did_xs ((Vars.empty, sh), (Vars.empty, sh')) + + + let fmt_caml _ = failwith "SH.fmt_caml unimplemented" +(* let fmt_caml ff q = *) +(* Format.fprintf ff *) +(* "@[(SH.PtS.star@ [@[%a@]]@]@ \ *) +(* @[(SH.LsS.star@ [@[%a@]]@]@ \ *) +(* @[(SH.DjS.star@ [@[%a@]]@]@;<1 1>\ *) +(* %s))))" *) +(* (List.fmt ";@ " Pt.fmt_caml) (Pts.to_list q.sfs.Fs.p) *) +(* (List.fmt ";@ " Ls.fmt_caml) (Lss.to_list q.sfs.Fs.l) *) +(* (List.fmt ";@ " Dj.fmt_caml) (Djs.to_list q.sfs.Fs.d) *) +(* (if q.jnk then "SH.tt" else "SH.emp") *) + + + + (* Labels ================================================================= *) + + let lbl q = q.lbl + + let labels q = + fold_sp + (fun _ () -> ()) + (fun q () ls -> IntSet.add q.lbl ls) + q () IntSet.empty + + + let relabel miss free q = + assert( IntSet.equal free (labels q) ) + ; + let rec map_fold fn sh z = + let sfs, z = + Fs.map_fold_djs (fun dj_z -> + Dj.map_fold (fun (dt, z) -> + map_fold fn dt z + ) dj_z + ) (sh.sfs, z) in + fn {sh with sfs} z + in + let fresh = IntSet.empty + and max = max (IntSet.max_elt miss) (IntSet.max_elt free) + in + let q, (fresh, _max) = + map_fold (fun q (fresh, max) -> + if IntSet.mem q.lbl miss then + let lbl = max + 1 in + ({q with lbl}, (IntSet.add lbl fresh, lbl)) + else + (q, (fresh, max)) + ) q (fresh, max) + in + (q, fresh) + + let relabel_extend (sh, lbls) = + let sh_lbls = labels sh in + let sh, new_lbls = relabel lbls sh_lbls sh in + let lbls = IntSet.union (IntSet.union new_lbls sh_lbls) lbls in + (sh, lbls) + + let set_lbl lbl q = + let q,_ = relabel (IntSet.singleton lbl) (labels q) q in + {q with lbl} + + + (* Syntactic Normalization ================================================ *) + + (* normalization uses an accumulator of type *) + type u = { p: E.t list; s: F.t list; j: bool; } + + let uemp = { p= []; s= []; j= false; } + + let u_of q = { p= Exps.to_list q.pas; s= Fs.to_list q.sfs; j= q.jnk; } + + let u_fmt ff u = + Format.fprintf ff "@[%a@,%a@,%s@]" + (List.fmt " *@ " E.fmt) u.p + (List.fmt " *@ " F.fmt) u.s + (if u.j then " * true" else "") + + + type cxt = { sub: E.t -> E.t; lss: LsB.t; locs: Exps.t } + + let id_cxt = { sub= (fun e -> e); lss= LsB.empty; locs= Exps.empty } + + (** [add_* s a (lbls0,q0,u0)] returns a tuple [(lbls1,q1,u1)] such that [q1] + * [u1] iff [a] * [q0] * [u0]. Applies [s] to freshly constructed + subformulas added to [(q1,u1)], and relabels such formulas to avoid + [lbls0] (returning extended set of labels [lbls1]). Progress is made + (at least) in the sense that [a] is not in [u1]. *) + + let add_jnk (lbls, q, u, n) = + assert(true$> L.printf 7 "add jnk" ); + (lbls, {q with jnk= true}, u, n) + + + let add_empty_eqs {sub} ls z = + List.map_append sub (Ls.empty_eqs ls) z + + + let rec add_pa cxt pa (lbls, q, u, n) = + assert( + L.printf 7 "add pa: %a" E.fmt pa ; + IntSet.subset (labels q) lbls + || failwithf "missing labels: {@[%a@]}" + (List.fmt ",@ " Format.pp_print_int) + (IntSet.to_list (IntSet.diff (labels q) lbls)) ); + match E.desc pa with + | _ when Config.sh_simplify && E.equal E.tt pa -> + (lbls, q, u, n) + + | _ when Config.sh_simplify && E.equal E.ff pa -> + (lbls, ff, uemp, false) + + | E.OpN(E.And,es) -> + let p = Array.fold_right (fun e ufs -> E.name e :: ufs) es u.p in + (lbls, q, {u with p}, n) + + | E.OpN(E.Or,es) -> + let dj, n = + Array.fold_right (fun e (dts, n) -> + let dt, n' = norm cxt (emp, {uemp with p= [E.name e]}) in + (Dj.add dt dts, n || n') + ) es (Dj.empty, n) in + let s = [Dj(dj)] in + (lbls, q, {u with s}, n) + + | _ -> + let pas = Exps.add pa q.pas in + (lbls, {q with pas}, u, n) + + + and add_sf ({lss; locs} as cxt) f (lbls, q, u, n) = + assert ( + L.printf 7 "add f: %a" F.fmt f ; + IntSet.subset (labels q) lbls + || failwithf "missing labels: {@[%a@]}" + (List.fmt ",@ " Format.pp_print_int) (IntSet.to_list (IntSet.diff (labels q) lbls)) + ); + match f with + | Pt({Pt.loc} as pt) -> + if E.equal loc E.nil then ( + (* 0->_ <=> ff *) + assert(true$> L.printf 8 "ff pt: %a" Pt.fmt pt ); + (lbls, ff, uemp, false) + ) + else if Exps.mem loc locs || Pts.memi loc q.sfs.Fs.p then ( + (* E->_ * E->_ <=> ff *) + assert(true$> L.printf 8 "must-alloc conflict" ); + (lbls, ff, uemp, false) + ) + else (match Option.fold List.cons (Lss.tryfind loc q.sfs.Fs.l) (LsB.find loc lss) with + | [] -> + assert(true$> L.printf 8 "add pt: %a" Pt.fmt pt ); + let sfs = Fs.add f q.sfs in + (lbls, {q with sfs}, u, n) + | lss -> + (* E->_ * ls(L,K,P,E,B,N) <=> K==0 * E==N * P==B *) + (* E->_ * ls(L,K,P,F,E,N) <=> K==0 * F==N * P==E *) + let sfs, p = + List.fold (fun ls (sfs, p) -> + assert(true$> L.printf 8 "ls conflict: %a" Ls.fmt ls ); + let p = add_empty_eqs cxt ls p in + let sfs = Fs.remove (Ls(ls)) sfs in + (sfs, p) + ) lss (q.sfs, u.p) in + let sfs = Fs.add f sfs in + (lbls, {q with sfs}, {u with p}, true) + ) + | Ls({Ls.len} as ls) -> + let may_allocs_ls = Exps.of_list (Ls.may_allocs ls) in + if E.equal E.zero len + (* ls(L,0,P,F,B,N) <=> F==N * P==B *) + || Exps.mem E.nil may_allocs_ls + (* ls(L,K,P,0,B,N) <=> K==0 * 0==N * P==B *) + (* ls(L,K,P,F,0,N) <=> K==0 * F==N * P==0 *) + || Exps.intersect locs may_allocs_ls + (* E->_ * ls(L,K,P,E,B,N) <=> K==0 * E==N * P==B *) + (* E->_ * ls(L,K,P,F,E,N) <=> K==0 * F==N * P==E *) + then ( + assert(true$> L.printf 8 "add empty ls: %a" Ls.fmt ls ); + let p = add_empty_eqs cxt ls u.p in + (lbls, q, {u with p}, true) + ) + else ( + let conflicts = + Exps.fold (fun e conflicts -> + match Fs.tryfind e q.sfs with + | Some(Ls(ls)) when not (List.mem ls conflicts) -> ls :: conflicts + | _ -> conflicts + ) may_allocs_ls [] + in + if conflicts = [] then ( + assert(true$> L.printf 8 "add ls: %a" Ls.fmt ls ); + let sfs = Fs.add f q.sfs in + (lbls, {q with sfs}, u, n) + ) + else ( + assert(true$> L.printf 8 "@[conflict: @[%a@]@]" (List.fmt ";@ " Ls.fmt) conflicts ); + let add_lss = List.fold (fun ls fs -> Fs.add (Ls(ls)) fs) in + let rem_lss = List.fold (fun ls fs -> Fs.remove (Ls(ls)) fs) in + (* Either ls is empty or all conflicting ls's are empty *) + (* ls(_,J,_,E,_,_) * ls(_,K,_,_,E,_) <=> J==0 v K==0 *) + let ls_empty = + let sfs = add_lss conflicts emp.sfs in + let p = add_empty_eqs cxt ls uemp.p in + fst (norm cxt ({emp with sfs}, {uemp with p})) in + let conflicts_empty = + let sfs = Fs.singleton f in + let p = List.fold (add_empty_eqs cxt) conflicts uemp.p in + fst (norm cxt ({emp with sfs}, {uemp with p})) in + let lbls = IntSet.add ls_empty.lbl lbls in + let lbls = IntSet.add conflicts_empty.lbl lbls in + let sfs = rem_lss conflicts q.sfs in + let s = Dj(Dj.of_list [ls_empty; conflicts_empty]) :: u.s in + (lbls, {q with sfs}, {u with s}, true) + ) + ) + | Dj(dj) -> + (* {tt \/ S} <=> {tt} *) + let dj = if not Config.sh_simplify then dj else + if Dj.exists (fun dt -> equal tt dt) dj + then Dj.singleton tt + else dj in + (* {ff \/ S} <=> {S} *) + let dj = if not Config.sh_simplify then dj else + Dj.filter (fun dt -> not (inconsistent dt)) dj in + (* {P \/ R} \/ S <=> {P \/ R \/ S} *) + let dj = if not Config.sh_simplify then dj else + Dj.fold (fun dt dj -> + match Fs.tryextract_djs dt.sfs with + | Some(dt_dj, sfs) when Fs.is_empty sfs -> + let dt' = {dt with sfs} in + Dj.fold (fun dt dj -> + Dj.add (star [dt'] dt) dj + ) dt_dj dj + | _ -> + Dj.add dt dj + ) dj Dj.empty in + let contains_eq es = Exps.exists (fun e -> match E.desc e with E.Eq _ -> true | _ -> false) es in + match Dj.to_list dj with + | [] (* when !simplify *) -> + assert(true$> L.printf 8 "ff dj" ); + (* \/{} <=> ff *) + (lbls, ff, uemp, false) + | [r] (* when !simplify *) -> + assert(true$> L.printf 8 "add singleton dj: %a" Dj.fmt dj ); + (* \/{Q} <=> Q *) + let lbls = IntSet.union (labels r) lbls in + (lbls, star [r] q, u, n || contains_eq r.pas) + | r::t::tl -> + assert(true$> L.printf 8 "add dj: %a" Dj.fmt dj ); + (* P * {[R * Q] \/ [R * S]} <=> P * R * {Q \/ S} *) + if Config.sh_hoist_common_subformulas then + let r_i, i, t_i = diff_inter_diff r t in + let raised, dj = + List.fold (fun dt (raised, dj) -> + let dt, raised, lower = diff_inter_diff dt raised in + ( raised + , Dj.add dt (Dj.map (fun dt -> syntactic_star lower dt) dj) ) + ) tl (i, Dj.of_list [r_i; t_i]) in + let n = n || contains_eq (Exps.diff raised.pas q.pas) in + (* relabel raised disjunctions if needed to avoid lbls *) + let lbls, raised = + let d, lbls = Djs.map_fold (Dj.map_fold relabel_extend) (raised.sfs.Fs.d, lbls) in + (lbls, {raised with sfs= {raised.sfs with Fs.d}}) in + (* relabel subformulas of dj if needed to avoid lbls *) + let dj, lbls = + Dj.fold (fun dt (dj,lbls) -> + let dt, lbls = relabel_extend (dt, lbls) in + (Dj.add dt dj, lbls) + ) dj (dj_empty, lbls) in + let sfs = Fs.add (Dj(dj)) q.sfs in + (lbls, star [raised] {q with sfs}, u, n) + else + let r_i_e, i, t_i_e = Exps.diff_inter_diff r.pas t.pas in + let r_i = {r with pas= r_i_e} in + let t_i = {t with pas= t_i_e} in + let add_pas e q = {q with pas= Exps.union e q.pas} in + let raised, dj = + List.fold (fun dt (raised, dj) -> + let dt_pas, raised', lower = Exps.diff_inter_diff dt.pas raised in + let dt = {dt with pas= dt_pas} in + ( raised' + , Dj.add dt (Dj.map (fun dt -> add_pas lower dt) dj) ) + ) tl (i, Dj.of_list [r_i; t_i]) in + let n = n || contains_eq (Exps.diff raised q.pas) in + let q = add_pas raised q in + (* relabel subformulas of dj if needed to avoid lbls *) + let dj, lbls = + Dj.fold (fun dt (dj,lbls) -> + let dt_lbls = labels dt in + let dt, new_lbls = relabel lbls dt_lbls dt in + let lbls = IntSet.union (IntSet.union new_lbls dt_lbls) lbls in + (Dj.add dt dj, lbls) + ) dj (dj_empty, lbls) in + let sfs = Fs.add (Dj(dj)) q.sfs in + (lbls, {q with sfs}, u, n) + (* Notes: + - Define a well-guardedness check that requires the stem + leading to a subformula to guard the existentials in the + subformula. + - Refine this normalization to only hoist subformulas that + remain well-guarded after hoisting. + - Prover.distrib_{pt,ls} should no longer be needed, remove + them. + - DjS.add no longer needs to violate normalization, remove it. + - Revise DjS operations to not assume incoming Dj.t's are + normalized + - Move normalization done by Dj.add to here. + *) + + + (** Normalization is a fixed-point computation at type [t * u]. [norm + (q,u)] selects the "first" atom of [u] and calls the appropriate + [add_*] function on it, yielding a new [t * u] pair. The argumet + substitution is applied to subformulas added to the result that do not + appear in [(q,u)]. *) + and norm cxt (q,u) = + let u = {u with p= List.filter (fun e -> not (E.equal E.tt e)) u.p} in + if u = uemp then (q, false) + else + let reset = L.latch() in (fun (q,_) -> assert(true$> L.resetf 50 reset "> norm: %a" fmt q )) + <& + let rec loop (lbls, q, u, new_eqs) = + assert(true$> L.incf 50 "< norm: @[q: %a@ u: %a@]" fmt q u_fmt u ); + match u with + | {p= pa :: l} -> loop (add_pa cxt pa (lbls, q, {u with p= l}, new_eqs)) + | {s= sf :: l} -> loop (add_sf cxt sf (lbls, q, {u with s= l}, new_eqs)) + | {j= true } -> loop (add_jnk (lbls, q, {u with j= false}, new_eqs)) + | _ -> (q, new_eqs) + in + loop (labels q, q, u, false) + + + + (* Constructors =========================================================== *) + + (** [star ps q] returns the iterated star conjunction of the [ps] and [q], + preserving the labels and congruence class representatives of [q]. *) + and star ps q = + assert(true$> + L.incf 5 "( SH.star: @[[%a] *@ %a@]" (List.fmt " *@ " fmt) ps fmt q ); + (fun q -> assert(true$> + L.decf 5 ") SH.star:@ %a" fmt q )) + <& + match ps with + | [] -> q + | [p] when equal p emp -> q + | [p] when equal q emp -> {p with lbl= q.lbl} + | p::ps -> fst (norm id_cxt (q, u_of (List.fold_left syntactic_star p ps))) + + + (** [disj ps q] returns the iterated disjunction of the [ps] and [q], + preserving the labels of [q]. *) + let disj ps q = + assert(true$> + L.incf 5 "( SH.disj:@ @[[%a] \\/@ %a@]" (List.fmt " \\/@ " fmt) ps fmt q ); + (fun q -> assert(true$> + L.decf 5 ") SH.disj:@ %a" fmt q )) + <& + (* relabel ps to avoid the labels of q, so that they are preserved *) + let dj,_ = + List.fold (fun p (dj, lbls) -> + let p, lbls = relabel lbls (labels p) p in + (Dj.add p dj, lbls) + ) ps (Dj.singleton q, labels q) in + fst (norm id_cxt (emp, {uemp with s= [Dj(dj)]})) + + + + (* Maps =================================================================== *) + + let rec map fn sh = +(* L.incf 0 "( SH.map: %a" fmt sh ; L.decf 0 ") SH.map: %a" fmt <& *) + let sh = + Fs.fold (fun f sh -> + let f' = + match f with + | Pt _ | Ls _ -> + f + | Dj(dj) -> + let dj = Dj.map (fun dt -> map fn dt) dj in + Dj(dj) + in + fst (norm id_cxt (sh, {uemp with s= [f']})) + ) sh.sfs {sh with sfs= Fs.empty} + in + fn sh + + + let rec map_fold fn sh z = +(* L.incf 0 "( map_fold: %a" Sh.fmt sh ; (fun (sh,_) -> L.decf 0 ") map_fold: %a" Sh.fmt sh) <& *) + let sh, z = + Fs.fold (fun f (sh, z) -> + let f', z = + match f with + | Pt _ | Ls _ -> + (f, z) + | Dj(dj) -> + let dj, z = Dj.map_fold (fun (dt,z) -> map_fold fn dt z) (dj,z) in + (Dj(dj), z) + in + (fst (norm id_cxt (sh, {uemp with s= [f']})), z) + ) sh.sfs ({sh with sfs= Fs.empty}, z) + in + fn sh z + + + let rec map_fold_sp dn up sh sa pa = +(* L.incf 0 "( map_fold_sp: %a" Sh.fmt sh ; (fun (sh,_) -> L.decf 0 ") map_fold_sp: %a" Sh.fmt sh) <& *) + let sh, sa = dn sh sa in + let sh, pa = + Fs.fold (fun f (sh, pa) -> + let f', pa = + match f with + | Pt _ | Ls _ -> + (f, pa) + | Dj(dj) -> + let dj, pa = Dj.map_fold (fun (dt,pa) -> map_fold_sp dn up dt sa pa) (dj,pa) in + (Dj(dj), pa) + in + (fst (norm id_cxt (sh, {uemp with s= [f']})), pa) + ) sh.sfs ({sh with sfs= Fs.empty}, pa) + in + up sh sa pa + + + let map_fold_distrib fn sh z = + let rec map_fold_distrib_ fn stem dt z = + let dt_stem, dt_djs = Fs.extract_all_djs dt.sfs in + (* star stem onto trimmed disjunct to preserve label of dt and associated metadata *) + let stem = star [stem] {dt with sfs= dt_stem} in + let stem, dt_djs, z = + Fs.fold_djs (fun dj (stem, djs, z) -> + let dj, z = + Dj.map_fold (fun (dt, z) -> + map_fold_distrib_ fn stem dt z + ) (dj, z) in + let dj,_ = norm id_cxt (emp, {uemp with s= [Dj(dj)]}) in + let dj_stem, dj_djs = Fs.extract_all_djs dj.sfs in + let stem = {stem with sfs= dj_stem} in + let dj = {dj with sfs= dj_djs} in + (stem, dj :: djs, z) + ) dt_djs (stem, [], z) in + let stem_s_dt = star dt_djs stem in + fn stem_s_dt z + in + map_fold_distrib_ fn emp sh z + + + + (* Substitution, etc. ===================================================== *) + + (** [map_exps_denorm fn (q,u)] applies [fn] to every atom [a] of [q]. The + input is not gratuitously copied, so if applying [fn] does not change + any atoms of [q], then [map_exps_denorm fn qu == qu]. The spatial + atoms changed by [fn] are moved to the accumulator [u], and the + remainder of [q] is still normalized. *) + let map_exps_denorm fn (q, u) = + (fun (q',_) -> assert( q == q' || not (equal q q') )) + <& + let pas, p = + Exps.fold (fun pa (pas, p) -> + let pa' = E.map fn pa in + if E.equal pa pa' + then (pas, p) + else (Exps.remove pa pas, pa' :: p) + ) q.pas (q.pas, u.p) + in + let sfs, s = + Fs.fold_filter (fun qf s -> + let qf' = F.map_exps (fun x -> E.map fn x) qf in + if F.equal qf qf' + then None + else Some(qf' :: s) + ) q.sfs u.s + in + if p = [] && s = [] then (q, u) else ({q with pas; sfs}, {u with p; s}) + + let map_exps fn q = +(* L.incf 10 "( SH.map_exps:@ %a" fmt q ; *) +(* L.decf 10 ") SH.map_exps:@ %a" fmt <& *) + (* clear the congruences as the transformation may invalidate them *) + let q0 = clear_cng q + in + let q1, u1 = map_exps_denorm fn (q0, uemp) + in + (* if nothing changed, keep the congruences *) + if u1 = uemp then q + else fst (norm {id_cxt with sub= fn} (q1, u1)) + + + let subst s q = +(* L.incf 0 "( SH.subst:@ %a@ %a" S.fmt s fmt q ; *) +(* L.decf 0 ") SH.subst:@ %a" fmt <& *) + if S.is_empty s then q else + map_exps (fun x -> try S.find x s with Not_found -> x) q + + + let renaming vs = + Vars.fold (fun v (fs,s,i) -> + let sort = Var.sort v in + let fresh = Var.gensym (Var.name v) sort in + let s' = S.add (E.mkVar v) (E.mkVar fresh) s in + let i' = S.add (E.mkVar fresh) (E.mkVar v) i in + (Vars.add fresh fs, s', i') + ) vs (Vars.empty, S.empty, S.empty) + + let rename_vs vs q = +(* L.incf 0 "( SH.rename_vs:@ @[{%a}@]@ %a" Vars.fmt vs fmt q; *) +(* (fun (q',_,s,_) -> L.decf 0 ") SH.rename_vs:@ %a@ %a" S.fmt s fmt q') *) +(* <& *) + let freshs, renaming, inverse = renaming vs in + (subst renaming q, freshs, renaming, inverse) + + + + (* Pure Formulas ===========================================================*) + + module Pf = struct + + let default_preorder xs e f = + let num_xs e = Vars.cardinal (Vars.inter xs (E.fv e)) in + let o = Pervasives.compare (num_xs e) (num_xs f) in + if o <> 0 then o < 0 else Exp.compare e f <= 0 + + let star pas q = + fst (norm id_cxt (q, {uemp with p= pas})) + + let term q = + E.mkAnd (Exps.to_array q.pas) + + let normalize q e = + CngRel.normalize q.fcr e + + let class_of q e = + CngRel.class_of q.fcr e + + let classes q = + Exps.fold (fun e' clss -> + Expss.add (class_of q e') clss + ) (CngRel.representatives q.fcr) Expss.empty + + let fold_classes fn q z = + CngRel.fold_classes fn q.fcr z + + let mem_carrier e q = + CngRel.mem_carrier e q.fcr + + let carrier q = + CngRel.carrier q.fcr + + let empty q = + {q with fcr= emp.fcr; tcr= emp.tcr; pas= emp.pas} + + let trim xs kills kill_to_keep q = + let leq e f = default_preorder xs e f in + let fcr = CngRel.remove_trivial q.fcr kills in + let tcr = CngRel.remove_trivial q.tcr kills in + let fcr = CngRel.subst leq fcr kill_to_keep in + let tcr = CngRel.subst leq tcr kill_to_keep in + {q with fcr; tcr} + + let union leq q r = +(* L.incf 0 "( SH.Pf.union:@ %a@ %a" CngRel.fmt q.fcr CngRel.fmt r.fcr ; *) +(* (fun {fcr} -> L.decf 0 ") SH.Pf.union:@ %a" CngRel.fmt fcr) <& *) + {q with fcr= CngRel.union leq q.fcr r.fcr} + + let merge leq q e f = +(* L.incf 0 "( SH.Pf.merge:@ %a = %a@ %a" E.fmt e E.fmt f CngRel.fmt q.fcr ; *) +(* (fun {fcr} -> L.decf 0 ") SH.Pf.merge:@ %a" CngRel.fmt fcr) <& *) + {q with fcr= CngRel.merge leq q.fcr e f} + + let extend xs q e = + let leq e f = default_preorder xs e f in + merge leq q e e + + let mem b q = + let b' = E.map (normalize q) b in + Exps.exists (fun e -> E.equal b' (E.map (normalize q) e)) q.pas + + end + + + + (* Normalization with respect to Disjunctive Congruence Closure =========== *) + + module ShFrm = struct + include Sh + module Exp = Exp + module Exps = Exps + module ExpMap = ExpMap + + let is_leaf q = Fs.is_empty_djs q.sfs + + let fold_rels _fn_scc fn q z = + (* add all pointer and offset expressions to relation *) + let z = + fold_exps (fun e z -> + (* Note: it should not be necessary to special case these *) + match E.desc e with E.Add _ | E.Sub _ | E.Idx | E.App({HC.desc= E.Idx},_) -> z | _ -> + match E.sort_of e with + | Var.PointerSort | Var.OffsetSort -> fn e e z + | _ -> z + ) q z in + (* add equations to relation *) + let z = + Exps.fold (fun e z -> + match E.desc e with + | E.Eq(e,f) -> + fn f e (fn f f (fn e e z)) + | _ -> + z + ) q.pas z in + z + + let fold_nrels fn q z = + (* add disequations to relation *) + Exps.fold (fun e z -> + match E.desc e with + | E.Op1(E.Not, E.Eq(e,f)) -> + fn e f z + | _ -> + z + ) q.pas z + + end + + (* Computes congruence closure logically, by expanding to DNF. *) + module DCC = DisjCngClos.Make (ShFrm) (CngRel) + + let dcc x = + let leq e f = Pf.default_preorder Vars.empty e f in + DCC.dcc leq x + + + let has_lit_off {Pt.off} sh = + Exps.exists (fun e -> + match Exp.desc e with + | Exp.Var _ -> false + | _ -> true + ) (Sh.Pf.class_of sh (off :> Exp.t)) + + let rec equates_off_to_lits pt dj = + Dj.for_all (fun dt -> + has_lit_off pt dt + || + Fs.exists_djs (fun dj -> + equates_off_to_lits pt dj + ) dt.sfs + ) dj + + let distrib_varoff_pts (sh, new_eqs) = + let sfs, new_eqs = + Fs.fold_pts (fun pt (sfs, n) -> + if has_lit_off pt sh then + (sfs, n) + else match + Fs.trytake_djs (fun dj -> + equates_off_to_lits pt dj + ) sfs + with + | Some(dj) -> + let dj', n = + Dj.map_fold (fun (dt, n) -> + let dt', n' = norm id_cxt (dt, {uemp with s= [Pt(pt)]}) in + (dt', n || n') + ) (dj, n) in + (Fs.add (Dj(dj')) (Fs.remove (Dj(dj)) (Fs.remove (Pt(pt)) sfs)), n) + | None -> + (sfs, n) + ) sh.sfs (sh.sfs, new_eqs) in + ({sh with sfs}, new_eqs) + + + module LsG = struct + + module Edge = struct + type t = Exp.t * Ls.t list * Exp.t + + let equal (u,k,v) (w,l,x) = + Exp.equal u w && Exp.equal v x && List.equal Ls.equal k l + + let compare (u,k,v) (w,l,x) = + let o = Exp.compare u w in if o<>0 then o else + let o = Exp.compare v x in if o<>0 then o else + List.compare Ls.compare k l + + let adjacent (_,_,v) (w,_,_) = + Exp.equal v w + + let append (u,k,_) (_,l,x) = + (u, k @ l, x) + end + + include Set.Make(Edge) + + let add_with_closure edg g = + let hds = + fold (fun g_edg h -> + if Edge.adjacent g_edg edg then + add (Edge.append g_edg edg) h + else + h + ) g empty + in + let tls = + fold (fun g_edg h -> + if Edge.adjacent edg g_edg then + add (Edge.append edg g_edg) h + else + h + ) g empty + in + let spn = + fold_product (fun hd_edg tl_edg h -> + add (Edge.append hd_edg tl_edg) h + ) hds tls empty + in + union spn (union tls (union hds (add edg g))) + + let add_ls foreward ls g = + match foreward, ls with + | true, {Ls.arg= {frnt= f::_; next= n::_}} -> add_with_closure (f, [ls], n) g + | false, {Ls.arg= {back= b::_; prev= p::_}} -> add_with_closure (b, [ls], p) g + | _ -> g + + end + + module LsGM = struct + include Map.Make(Patn) + + let extend sh lsgm = + Fs.fold_lss (fun ({Ls.pat} as ls) lsgm -> + let flsg, blsg = Option.get_or (tryfind pat lsgm) (LsG.empty, LsG.empty) in + let flsg = LsG.add_ls true ls flsg in + let blsg = LsG.add_ls false ls blsg in + add pat (flsg, blsg) lsgm + ) sh.sfs lsgm + end + + let must_allocs_ dnf sh lsgm locs = + let must_allocs_pts {sfs} locs = + Fs.fold_pts (fun {Pt.loc} locs -> + Exps.add loc locs + ) sfs locs + in + let must_allocs_nonempty_lss {fcr} lsgm locs = + LsGM.fold (fun _pat (flsg, blsg) locs -> + let add_nonempty foreward lsg locs = + LsG.fold (fun (u,l,v) locs -> + if CngRel.mem_dqs fcr u v then + List.fold (fun {Ls.arg= {frnt; back}} locs -> + if foreward then + Exps.adds frnt locs + else + Exps.adds back locs + ) l locs + else + locs + ) lsg locs + in + locs |> + add_nonempty true flsg |> + add_nonempty false blsg + ) lsgm locs + in + let rec must_allocs_terminated_lss ({sfs} as sh) locs0 = + let locs = + Fs.fold_lss (fun {Ls.arg} locs -> + Args.fold_links (fun (l,r) locs -> + if Exps.mem l locs then + Exps.add r locs + else + locs + ) arg locs + ) sfs locs0 + in + if not (Exps.equal locs locs0) then + must_allocs_terminated_lss sh locs + else + locs + in + let close_wrt_tcr {tcr} locs = + Exps.fold (fun e locs -> + Exps.union (CngRel.class_of tcr e) locs + ) locs locs + in + fold_dnf ~dnf + (fun dt ((lsgm, clocs), dlocs) -> + let lsgm = LsGM.extend dt lsgm in + let clocs = + clocs |> + must_allocs_pts dt |> + must_allocs_nonempty_lss dt lsgm |> + must_allocs_terminated_lss dt |> + close_wrt_tcr dt + in + ((lsgm, clocs), dlocs) + ) + (fun ((_lsgm, clocs), dlocs) -> + Some(Option.fold Exps.inter dlocs clocs) + ) + sh (lsgm, locs) None |> + Option.or_get Exps.empty + + let must_allocs sh = + must_allocs_ true sh LsGM.empty Exps.empty + + + let fmtn ff sh = fmtsp emp (Vars.empty,Vars.empty) ff sh + + let extend_lsgm_locs dnf sh sfl lsgm locs = + let sh_sf,_ = norm id_cxt (sh, {uemp with s= sfl}) in + let lsgm = LsGM.extend sh_sf lsgm in + let locs = must_allocs_ dnf sh_sf lsgm locs in + (lsgm, locs) + + + let denorm_conflicts dnf sh ush lsgm locs = + let sfs, ush, lsgm, locs = + Fs.fold (fun sf (sfs, ush, lsgm, locs) -> + if Exps.intersect (F.may_allocs sf) locs then + let sfs = Fs.remove sf sfs in + let ush = {ush with s= sf :: ush.s} in + (sfs, ush, lsgm, locs) + else + let lsgm, locs = extend_lsgm_locs dnf emp [sf] lsgm locs in + (sfs, ush, lsgm, locs) + ) sh.sfs (sh.sfs, ush, lsgm, locs) in + ({sh with sfs}, ush, lsgm, locs) + + + let renorm dnf ({locs} as cxt) sh ush lsgm new_eqs = + let sh, new_eqs' = norm cxt (sh, ush) in + let new_eqs = new_eqs || new_eqs' in + let locs = must_allocs_ dnf sh lsgm locs in + (lsgm, locs, sh, new_eqs) + + + let rec normalize_ ?(init=emp) dnf xs sh = + let cm = + let leq e f = Pf.default_preorder xs e f in + DCC.dcc ~dnf leq ~init:init.fcr sh + in + let rec normalize_rec lss lsgm locs (dt, new_eqs) = + assert(true$>( + L.incf 20 "( normalize_rec: {@[%a@]}@ %a" Exps.fmt locs fmtn dt )) ; + (fun (dt,_) -> assert(true$>( + L.decf 20 ") normalize_rec: %a" fmtn dt ))) + <& + (* find congruence relations for dt *) + match IntMap.tryfind dt.lbl cm with + | None -> + (* the disjunction structure has changed during normalization + due to expanding conflicting lists into a disjunction *) + assert( new_eqs ); + (dt, new_eqs) + | Some(fcr, tcr) -> + let dt = {dt with fcr; tcr} in + let sub = Pf.normalize dt in + (* simplify inconsistent formulas *) + if CngRel.inconsistent dt.fcr then + ({ff with lbl= dt.lbl}, false) + else + let lsgm, locs, dt, new_eqs = + (* denorm stem subformulas changed by normalizing wrt congruence *) + let stem = {dt with sfs= Fs.clear_djs dt.sfs} in + let stem, ustem = map_exps_denorm sub (stem, uemp) in + (* conjoin implied (dis)equalities *) + let ustem = + let p = + ustem.p |> + CngRel.fold (fun e' e p -> E.mkEq e' e :: p) dt.fcr |> + CngRel.foldn (fun e' e p -> E.mkDq e' e :: p) dt.fcr in + {ustem with p} in + (* denorm stem pts and lss whose may-allocs intersect locs *) + let stem, ustem, lsgm, locs = denorm_conflicts dnf stem ustem lsgm locs in + (* normalize stem *) + let lsgm, locs, stem, new_eqs = renorm dnf {sub; lss; locs} stem ustem lsgm new_eqs in + (* recombine the stem and disjunctions *) + let dt, new_eqs = + let dt, new_eqs' = norm {sub; lss; locs} (stem, {uemp with s= Fs.to_list (Fs.only_djs dt.sfs)}) in + let new_eqs = new_eqs || new_eqs' in + (dt, new_eqs) in + (lsgm, locs, dt, new_eqs) in + (* distribute points-tos with variable offsets to literal equations *) + let dt, new_eqs = distrib_varoff_pts (dt, new_eqs) in + (* recurse over each disjunct of each disjunction individually *) + let stem = {dt with sfs= Fs.clear_djs dt.sfs} in + let ustem, lsgm, new_eqs = + let djs, lsgm, new_eqs = + (* extend stem lists *) + let lss' = Fs.fold_lss LsB.add stem.sfs lss in + let rec normalize_djs djs' lsgm new_eqs done_fs todo_djs = + match todo_djs with + | Dj(dj) :: todo_djs -> + (* extend locs with must-allocs of stem and other disjunctions *) + let lsgm', locs' = extend_lsgm_locs dnf done_fs todo_djs lsgm locs in + let dj', new_eqs' = Dj.map_fold (normalize_rec lss' lsgm' locs') (dj, new_eqs) in + let done_fs',_ = norm id_cxt (done_fs, {uemp with s= [Dj(dj)]}) in + normalize_djs (Djs.add dj' djs') lsgm' new_eqs' done_fs' todo_djs + | [] -> + (djs', lsgm, new_eqs) + | _ -> + assert false + in + let djs, lsgm, new_eqs = + let todo_djs = Fs.fold_djs (fun dj djs -> Dj(dj) :: djs) dt.sfs [] in + normalize_djs Djs.empty lsgm new_eqs stem todo_djs in + (djs, lsgm, new_eqs) in + (* add updated disjunctions to stem *) + let ustem = {uemp with s= Djs.fold (fun dj ufs -> Dj(dj) :: ufs) djs []} in + (ustem, lsgm, new_eqs) in + let _,_, dt, new_eqs = renorm dnf {sub; lss; locs} stem ustem lsgm new_eqs in + (dt, new_eqs) + in + let sh, new_eqs = normalize_rec LsB.empty LsGM.empty Exps.empty (sh, false) + in + if new_eqs then + normalize_ ~init dnf xs sh + else + sh + + + let normalize ?(dnf=true) ?init (xs, sh) = + assert(true$>( + L.incf 10 "( SH.normalize:@ %a" (fmtsp emp (mk_fxt (xs, sh))) sh )); + Timer.start normalize_tmr ; + (fun (xs',sh') -> + Timer.stop normalize_tmr ; assert(true$>( + L.decf 10 ") SH.normalize:@ %a" (fmtsp emp (mk_fxt (xs', sh'))) sh' ))) + <& + let sh' = normalize_ ?init dnf xs sh in + let xs' = Vars.inter xs (fv sh') in + (xs', sh') + +(* let normalize ?(dnf=true) ?init (xs, sh) = *) +(* debug_wrap3 Config.vSH 10 (fun dnf init xsh -> normalize ~dnf ?init xsh) *) +(* dnf init (xs, sh) *) + + + let normalize_stem ?(init=emp) (xs, sh) = + assert(true$>( + L.incf 10 "( SH.normalize_stem:@ %a" + XSh.fmt (xs, {sh with fcr= init.fcr; tcr= init.tcr}) )); + Timer.start normalize_stem_tmr ; + (fun (xsh',_) -> + Timer.stop normalize_stem_tmr ; assert(true$>( + L.decf 10 ") SH.normalize_stem:@ %a" XSh.fmt xsh' ))) + <& + let stem, djs = Fs.extract_all_djs sh.sfs in + let stem' = normalize_ ~init false xs {sh with sfs= stem} in + let sh' = {stem' with sfs= Fs.union stem'.sfs djs} in + let xs' = Vars.inter xs (fv sh') in + let eqs = + CngRel.fold (fun e' e eqs -> + if CngRel.mem init.fcr e' e || CngRel.mem sh.fcr e' e + then eqs + else Exps.add (E.mkEq e' e) eqs + ) sh'.fcr Exps.empty in + ((xs', sh'), eqs) + + + + (* Quantifier Operations ================================================== *) + + + let exists_elim_id = ref 0 + + (* Note: dnf could perhaps be false by default once subformulas are ordered + by a guarding preorder *) + let exists_elim ?(dnf=true) (xs, sh) = + assert(true$>( + incr exists_elim_id ; + L.incf 10 "( SH.exists_elim %i:@ %a" !exists_elim_id XSh.fmt (xs, sh) )); + Timer.start exists_elim_tmr ; + (fun xsh' -> + Timer.stop exists_elim_tmr ; assert(true$>( + L.decf 10 ") SH.exists_elim:@ %a" XSh.fmt xsh' ))) + <& + if Vars.is_empty xs || not Config.sh_simplify then (xs, sh) + else + let xs, sh = normalize ~dnf ~init:sh (xs, sh) + in + (* build substitution from existentials to equal, preferably universal, exps *) + let extend_subst xs fcr (ks, subst) = + let xs_ks = Vars.diff xs ks in + Vars.fold (fun v (ks, subst) -> + let x = E.mkVar v in + let eqc = Exps.remove x (CngRel.class_of fcr x) in + if Exps.is_empty eqc then (ks, subst) else +(* L.printf 0 "v: %a eqc: {@[%a@]}" Var.fmt v Exps.fmt eqc ; let()=()in *) + let vs = + Exps.fold (fun e vs -> + match Exp.desc e with + | Exp.Var(v) when Vars.mem v xs_ks -> Vars.add v vs + | _ -> vs + ) eqc (Vars.singleton v) + in + let vs_ks = Vars.union vs ks + in + let map_vs_to_exp_disjoint_from zs = + let e = Exps.take (fun e -> Vars.disjoint (E.fv e) zs) eqc in + let subst = + Vars.fold (fun v subst -> + S.add (E.mkVar v) e subst + ) vs subst in + (vs_ks, subst) + in + try + map_vs_to_exp_disjoint_from xs + with Not_found -> try + map_vs_to_exp_disjoint_from vs_ks + with Not_found -> try + map_vs_to_exp_disjoint_from ks + with Not_found -> + (ks, subst) + ) xs_ks (ks, subst) + in + let rec subst_xs (ks, subst) (dt,sm) = +(* L.incf 10 "( subst_xs: %i" dt.lbl ; (fun (sh,_) -> L.decf 10 ") subst_xs: %a" fmt sh) <& *) + (* find congruence relations for dt *) + let {fcr; tcr} = dt in +(* L.printf 0 "fcr : %a" CngRel.fmt fcr ; *) +(* L.printf 0 "tcr : %a" CngRel.fmt tcr ; *) + (* construct substitution for existentials *) + let ks, subst = extend_subst xs fcr (ks, subst) in +(* L.printf 0 "subst: %a" S.fmt subst ; *) + (* remember the substitution to trim congruences *) + let sm = IntMap.add dt.lbl subst sm in + (* recurse over each disjunct of each disjunction individually *) + let sfs, sm = + Fs.map_fold_djs (fun dj_sm -> + Dj.map_fold (fun dt_sm -> + subst_xs (ks, subst) dt_sm + ) dj_sm + ) (dt.sfs, sm) in + (* substitute universal exps for existentials in stem *) + let stem = {dt with fcr; tcr; sfs= Fs.clear_djs sfs} in + let sub = (fun e -> S.subst subst e) in + let stem', ustem' = map_exps_denorm sub (stem, uemp) in +(* L.printf 0 "subst: %a" S.fmt subst ; *) +(* L.printf 0 "stem : %a" fmt stem ; *) +(* L.printf 0 "stem': %a" fmt stem' ; *) + (* add updated disjunctions to stem *) + let s = Fs.fold_djs (fun dj ufs -> Dj(dj) :: ufs) sfs ustem'.s in + (fst (norm {id_cxt with sub} (stem', {ustem' with s})), sm) + in + (* substitute for xs *) + let sh, sm = subst_xs (Vars.empty, S.empty) (sh, IntMap.empty) in + (* kill equations only for xs that were eliminated *) + let fs = fv ~include_cng_rels:false sh in +(* L.printf 0 "fs: {@[%a@]}" Vars.fmt fs ; *) + let kills = Vars.fold (fun k es -> Exps.add (E.mkVar(k)) es) (Vars.diff xs fs) Exps.empty in + let sh', () = + map_fold_sp + (fun dt subst -> + (* lookup subst to trim congruences, or use parent's *) + (dt, try IntMap.find dt.lbl sm with Not_found -> subst) + ) + (fun dt subst () -> +(* L.incf 10 "( up: %a" fmt dt ; (fun (dt',_) -> L.decf 10 ") up: %a" fmt dt' ) <& let()=()in *) + (* trim killed variables from congruences *) +(* L.printf 0 "subst : %a" S.fmt subst ; *) + let subst = S.remove_vs fs subst in +(* L.printf 0 "subst': %a" S.fmt subst ; *) + let dt = Pf.trim xs kills subst dt in + (* conjoin implied equalities *) + let p = + CngRel.fold (fun e' e p -> + Pf.normalize dt (E.mkEq e' e) :: p + ) dt.fcr [] in + let sub e = Pf.normalize dt e in + (fst (norm {id_cxt with sub} (dt, {uemp with p})), ()) + ) + sh S.empty () in + let xs' = Vars.inter xs (fv sh') in + (xs', sh') + +(* let exists_elim ?(dnf=true) (xs, sh) = *) +(* debug_wrap2 Config.vSH 10 (fun dnf xsh -> exists_elim ~dnf xsh) dnf (xs, sh) *) + + + let exists_intro vs sh = XSh.exists_intro vs (XSh.inj sh) + + + + (* Sets of Subformulas ==================================================== *) + + module PtS = struct + let embed pts sh = + {sh with sfs= + Pts.fold (fun pt fs -> Fs.add (Pt(pt)) fs) pts (Fs.clear_pts sh.sfs)} + let project sh = Fs.fold_pts Pts.add sh.sfs Pts.empty + include + (Set.Lift + (struct include Pts type elt = Pt.t end) + (struct + type t = Sh.t + type s = Pts.t + let embed = embed + let project = project + end) + : (sig + include Set.Q with type elt = Pt.t and type t = Sh.t + val remove : elt -> t -> t + val empty : t -> t + end)) + let find l q = Pts.find l (project q) + let may_allocs q = Pts.may_allocs (project q) + let star pts q = fst (norm id_cxt (q, {uemp with s= List.map (fun x -> Pt(x)) pts})) + end + + module LsS = struct + let embed lss sh = + {sh with sfs= + Lss.fold (fun ls fs -> Fs.add (Ls(ls)) fs) lss (Fs.clear_lss sh.sfs)} + let project sh = Fs.fold_lss Lss.add sh.sfs Lss.empty + include + (Set.Lift + (struct include Lss type elt = Ls.t end) + (struct + type t = Sh.t + type s = Lss.t + let embed = embed + let project = project + end) + : (sig + include Set.Q with type elt = Ls.t and type t = Sh.t + val remove : elt -> t -> t + val empty : t -> t + end)) + let find l q = Lss.find l (project q) + let may_allocs q = Lss.may_allocs (project q) + let star lss q = fst (norm id_cxt (q, {uemp with s= List.map (fun x -> Ls(x)) lss})) + end + + module DjS = struct + let embed djs sh = + {sh with sfs= + Djs.fold (fun dj fs -> Fs.add (Dj(dj)) fs) djs (Fs.clear_djs sh.sfs)} + let project sh = Fs.fold_djs Djs.add sh.sfs Djs.empty + include + (Set.Lift + (struct include Djs type elt = Dj.t end) + (struct + type t = Sh.t + type s = Djs.t + let embed = embed + let project = project + end) + : (sig + include Set.Q with type elt = Dj.t and type t = Sh.t + val add : elt -> t -> t (* Note: remove *) + val map : (elt -> elt) -> t -> t + val remove : elt -> t -> t + val filter : (elt -> bool) -> t -> t + val empty : t -> t + end)) + + let star djs q = fst (norm id_cxt (q, {uemp with s= List.map (fun x -> Dj(x)) djs})) + + let fold_semiring add mul fn q = Djs.fold_semiring add mul fn (project q) + + let extract_all q = + let stem, djs = Fs.extract_all_djs q.sfs in + ({q with sfs= stem}, {q with sfs= djs}) +(* + let map fn sh = +(* L.incf 0 "( DjS.map: %a" fmt sh ; L.decf 0 ") DjS.map: %a" fmt <& *) + star (Djs.to_list (Djs.map fn sh.djs)) (empty sh) + + let map_fold fn (sh,z) = + let djs', z' = Djs.map_fold fn (sh.djs, z) in + (star (Djs.to_list djs') (empty sh), z') + + let map_foldi fn (sh,z) = + let djs',z' = Djs.map_foldi fn (sh.djs, z) in + if Djs.equal djs' sh.djs then (sh, z') else + (star (Djs.to_list djs') (empty sh), z') +*) + end + + module Jnk = struct + let star q = {q with jnk= true} + let remove q = {q with jnk= false} + let is_empty q = not (q.jnk) + end + + + + (* Destructors ============================================================ *) + + let pure_sf q = + let rec pure_sf_ q = + E.mkAnd (Array.of_list + (DjS.fold (fun dj cn -> + E.mkOr (Array.of_list + (Dj.fold (fun dt dn -> pure_sf_ dt :: dn) dj [])) + :: cn + ) q (E.tt :: Exps.to_list q.pas))) + in + pure_sf_ q + + let rec spatial_sf q = + DjS.map (Dj.map spatial_sf) {q with fcr= emp.fcr; tcr= emp.tcr; pas= emp.pas} + + + + (* Logical Normalization ================================================== *) + + module ExpIMMap = ImperativeMultiMap.Make(Exp)(Exps) + + + (** [pure_consequences q] is [(ps,c,d)] where + [?xs. q ==> (?ps,xs. c ^ d) /\ (!ps.?xs. c ==> d)]. *) + let pure_consequences q = + assert(true$> + L.incf 10 "( pure_consequences:@ %a" fmt q); + Timer.start pure_consequences_tmr ; + (fun (ps,c,d) -> + Timer.stop pure_consequences_tmr ; assert(true$> + L.decf 10 ") pure_consequences:@ {@[%a@]}@ %a@ %a" + Vars.fmt ps E.fmt c E.fmt d)) + <& + let prtn_to_locs = ExpIMMap.create () + in + let rec aux prtno vs xs sh = +(* L.incf 0 "( aux sh: %a" fmt sh ; L.decf 0 ") to sh': %a" E.fmt <& *) + let sh' = + map (fun q -> +(* L.incf 0 "( map q: %a" fmt q ; L.decf 0 ") to q': %a" fmt <& *) + let bs = q.pas + in + let bs = + PtS.fold (fun {Pt.loc} bs -> + if Vars.intersect xs (E.fv loc) then + bs + else + let prtn = + match prtno with + | Some(prtn) -> prtn + | None -> E.mkVar (Var.gensym "prtn" Var.BooleanSort) in + ExpIMMap.add prtn_to_locs prtn loc ; + Exps.add prtn (Exps.add (E.mkAllocd loc) bs) + ) q bs + in + let do_one vs xs zs prtn cn pat ends = + let ys, ls_one = + XSh.exists_bind vs + (XSh.exists_intro zs + (XSh.Pf.star cn (Patn.instantiate pat ends))) in + let vs = Vars.union vs ys in + let xs = Vars.union xs ys in + let aux_one = aux (Some(prtn)) vs xs ls_one in + (* Note: Avoid this weakening by adding exist'ls to E.boolean *) +(* L.printf 0 "aux_one : %a" E.fmt_b aux_one ; *) + let aux_one = + E.remove (function + | E.Var(x) -> Vars.mem x xs |_-> false + ) aux_one in +(* L.printf 0 "aux_one': %a" E.fmt_b aux_one ; *) + (vs, xs, aux_one) + in + let bs = + LsS.fold (fun ({Ls.pat; len; arg} as ls) bs -> +(* L.incf 0 "( ls: %a" Ls.fmt ls ; *) +(* (fun bl -> L.decf 0 ") to: %a" E.fmt (List.hd bl)) *) +(* <& *) + let len_zero = E.mkAnd (Array.of_list (Ls.empty_eqs ls)) + in +(* L.printf 0 "len_zero: %a" E.fmt len_zero ; *) + let sprtn = E.mkVar (Var.gensym "sprtn" Var.BooleanSort) in + let fprtn = E.mkVar (Var.gensym "fprtn" Var.BooleanSort) in + let bprtn = E.mkVar (Var.gensym "bprtn" Var.BooleanSort) + in + let vs, xs, len_one = + do_one vs xs Vars.empty sprtn [E.mkEq len E.one] pat arg + in +(* L.printf 0 "len_one: %a" E.fmt len_one ; *) + let zs, fnt, bck = Ls.split_on_fresh_point ls + in + let vs, xs, len_fnt = + do_one vs xs zs fprtn [E.mkZGt len E.one] pat fnt + in + let _vs, _xs, len_many = + do_one vs xs zs bprtn [len_fnt] pat bck + in +(* L.printf 0 "len_many: %a" E.fmt len_many ; *) + Exps.add (E.mkOr [|len_zero; len_one; len_many|]) bs + ) q bs + in + {q with pas= bs; sfs= Fs.only_djs q.sfs} + ) sh + in + pure_sf sh' + in + let c = aux None (fv q) Vars.empty q + in + let ps, ites, _ = + ExpIMMap.fold (fun prtn loc (ps, ites, i) -> + let guard = E.mkAnd [|prtn; E.mkAllocd loc|] in + ( Vars.union (E.fv prtn) ps + , (E.mkIte guard loc (E.mkNum i)) :: ites + , Int64.pred i ) + ) prtn_to_locs (Vars.empty, [E.nil], -1L) + in + let d = E.mkDistinct (Array.of_list ites) + in + (ps, c, d) + + + let labeled_pure_consequences q = + assert(true$> + L.incf 10 "( labeled_pure_consequences:@ %a" fmt q ); + Timer.start labeled_pure_consequences_tmr ; + (fun (c,_) -> + Timer.stop labeled_pure_consequences_tmr ; assert(true$> + L.decf 10 ") labeled_pure_consequences:@ %a" E.fmt c)) + <& + let prtn_to_locs = ExpIMMap.create () + in + let rec aux prtn vs xs q = +(* L.incf 0 "( aux q: %a" fmt q ; L.decf 0 ") aux: %a" Exps.fmt <& *) + let bs = q.pas + in + let bs = + PtS.fold (fun {Pt.loc} bs -> + if Vars.intersect xs (E.fv loc) then + bs + else ( + ExpIMMap.add prtn_to_locs prtn loc ; + Exps.add prtn (Exps.add (E.mkAllocd loc) bs) + ) + ) q bs + in + let do_one vs xs zs prtn cn pat ends = + let ys, ls_one = + XSh.exists_bind vs + (XSh.exists_intro zs + (XSh.Pf.star cn (Patn.instantiate pat ends))) in + let vs = Vars.union vs ys in + let xs = Vars.union xs ys in + let aux_one = pure_sf (map (fun q -> {q with pas= aux prtn vs xs q}) ls_one) in + (* Note: Avoid this weakening by adding exist'ls to E.boolean *) +(* L.printf 0 "aux_one : %a" E.fmt aux_one ; *) + let aux_one = E.remove (function E.Var(x) -> Vars.mem x xs |_-> false) aux_one in +(* L.printf 0 "aux_one': %a" E.fmt aux_one ; *) + (vs, xs, aux_one) + in + let bs = + LsS.fold (fun ({Ls.pat; len; arg} as ls) bs -> +(* L.incf 0 "( ls: %a" Ls.fmt ls ; L.decf 0 ") to: %a" Exps.fmt <& *) + let len_zero = E.mkAnd (Array.of_list (Ls.empty_eqs ls)) + in +(* L.printf 0 "len_zero: %a" E.fmt len_zero ; *) + let sprtn = E.mkVar (Var.gensym "sprtn" Var.BooleanSort) in + let fprtn = E.mkVar (Var.gensym "fprtn" Var.BooleanSort) in + let bprtn = E.mkVar (Var.gensym "bprtn" Var.BooleanSort) + in + let vs, xs, len_one = + do_one vs xs Vars.empty sprtn [E.mkEq len E.one] pat arg + in +(* L.printf 0 "len_one: %a" E.fmt len_one ; *) + let zs, fnt, bck = Ls.split_on_fresh_point ls + in + let vs, xs, len_fnt = + do_one vs xs zs fprtn [E.mkZGt len E.one] pat fnt + in + let _vs, _xs, len_many = + do_one vs xs zs bprtn [len_fnt] pat bck + in +(* L.printf 0 "len_many: %a" E.fmt len_many ; *) + Exps.add (E.mkOr [|len_zero; len_one; len_many|]) bs + ) q bs + in + bs + in + let vs = fv q + in + let prop_q, (lbl_to_prop, implications) = + map_fold_sp + (fun q _ -> (q, q.lbl)) + (fun q lbl (lbl_to_prop, implications) -> +(* L.incf 0 "( map q: %a" fmt q ; (fun (q',_) -> L.decf 0 ") to q': %a" fmt q') <& *) + let prop = E.mkVar (Var.gensym "lbl" Var.BooleanSort) in +(* let prop = E.mkVar (Var.gensym ("lbl_"^(string_of_int lbl)) Var.BooleanSort) in *) + let pas, pure = + if Config.weak_pure_consequences then + (Exps.singleton prop, pure_sf q) + else + let pas = aux (E.mkVar (Var.gensym "prtn" Var.BooleanSort)) vs Vars.empty q in + (pas, pure_sf {q with pas}) + in + let q' = {q with pas; sfs= Fs.only_djs q.sfs} in + let implications' = E.mkImp prop pure :: implications in + let lbl_to_prop' = IntMap.add lbl prop lbl_to_prop in + (q', (lbl_to_prop', implications')) + ) + q q.lbl (IntMap.empty, []) + in + let _, ites, _ = + ExpIMMap.fold (fun prtn loc (ps, ites, i) -> + ( Vars.union (E.fv prtn) ps + , (E.mkIte (E.mkAnd [|prtn; E.mkAllocd loc|]) loc (E.mkNum i)) :: ites + , Int64.pred i + ) + ) prtn_to_locs (Vars.empty, [E.nil], -1L) + in + (E.mkAnd (Array.of_list (E.mkDistinct (Array.of_list ites) :: pure_sf prop_q :: implications)), lbl_to_prop) + + + + (* shadow ground values that cannot be exported from recursive module *) + let emp () = emp + let tt () = tt + let ff () = ff +end + + + +(*XSh========================================================================= + eXistentially quantified Symbolic Heap formulas + ============================================================================*) + +and XSh : sig + include + (EXISTENTIAL_SYMBOLIC_HEAP + with type t = Vars.t * Sh.t and type sh := Sh.t + and type pt := Pt.t and type ls := Ls.t and type dj := Dj.t) + + (* internal operations *) + val inj : Sh.t -> t + + (* shadow ground values that cannot be exported from recursive module *) + val emp : unit -> t + val tt : unit -> t + val ff : unit -> t + +end = struct + + include (Sh_t : module type of Sh_t with type t := Sh_t.t) + + type t = Vars.t * Sh_t.t + + + + (* Formatting ============================================================= *) + + let fmtp fxt ff xsh = Sh.fmtp_xs fxt ff xsh + + let fmt ff xsh = fmtp (Sh.mk_fxt xsh) ff xsh + + let fmtp_xs = fmtp + let fmt_xs = fmt + + let fmt_did = Sh.fmt_did_xs + let fmt_did_xs = fmt_did + + + let fmt_caml ff (xs,sh) = + Format.fprintf ff + "@[(SH.exists_intro@\n @[(Vars.of_list [@[%a@]])@\n \ + @[%a@])@]@]" + (List.fmt ";@ " Var.fmt_caml) (Vars.to_list xs) + Sh.fmt_caml sh + + + + (* Iterators ============================================================== *) + + (* Notes: Is ignoring the existentials in both map and fold here correct? *) + let map_exps fn (xs,q) = (xs, Sh.map_exps fn q) + + let fold_exps fn (_,q) = Sh.fold_exps fn q + + + + (* Quantifier Operations ================================================== *) + + let inj q = (Vars.empty, q) + + + let exists_bind cxt (xs,sh) = + let ws, xs_m_cxt = Vars.inter_diff xs cxt in + let sh', ws', _, _ = Sh.rename_vs ws sh in + (Vars.union ws' xs_m_cxt, sh') + + + let exists_binds cxt xshs = + let _, fv_shs, xs, shs = + List.fold (fun xsh (cxt, fv_shs, xs, shs) -> + let ys, sh = exists_bind cxt xsh in + let fv_sh = Sh.fv sh in + let cxt' = Vars.union fv_sh cxt in + let fv_shs' = Vars.union fv_sh fv_shs in + let xs' = Vars.union xs ys in + let shs' = sh :: shs in + (cxt', fv_shs', xs', shs') + ) xshs (cxt, Vars.empty, Vars.empty, []) + in + (fv_shs, xs, shs) + + + let exists_intro vs (xs,sh as xsh) = + assert(true$>( + L.incf 10 "( XSH.exists_intro:@ {@[%a@]}@ %a" Vars.fmt vs fmt xsh )) ; + (fun xsh' -> assert(true$>( + L.decf 10 ") XSH.exists_intro:@ %a" fmt xsh' ))) + <& + if Vars.is_empty vs then xsh else + Sh.exists_elim (Vars.union vs xs, sh) + + + + (* Queries ================================================================ *) + + let inconsistent (_,sh) = Sh.inconsistent sh + + let is_empty (_,sh) = Sh.is_empty sh + let is_pure (_,sh) = Sh.is_pure sh + + let sizeof (_,sh) = Sh.sizeof sh + + let fv (xs,q) = Vars.diff (Sh.fv q) xs + + let lbl (_,sh) = Sh.lbl sh + let set_lbl lbl (xs,sh) = (xs, Sh.set_lbl lbl sh) + + + + (* Base Constructors ====================================================== *) + + let emp = inj (Sh.emp()) + let tt = inj (Sh.tt()) + let ff = inj (Sh.ff()) + + + + (* Constructors =========================================================== *) + + let star pl q = + assert(true$> + L.incf 5 "( XSH.star: @[[%a] *@ %a@]" + (List.fmt " *@ " fmt) pl fmt q ); + (fun q -> assert(true$> + L.decf 5 ") XSH.star:@ %a" fmt q )) + <& + let fv_ps, xs, ps = exists_binds (fv q) pl in + let ys, q = exists_bind fv_ps q in + Sh.exists_intro (Vars.union xs ys) (Sh.star ps q) + + + let disj pl q = + assert(true$> + L.incf 5 "( XSH.disj: @[[%a] v@ %a@]" + (List.fmt " v@ " fmt) pl fmt q ); + (fun q -> assert(true$> + L.decf 5 ") XSH.disj:@ %a" fmt q )) + <& + let fv_ps, xs, ps = exists_binds (fv q) pl in + let ys, q = exists_bind fv_ps q in + Sh.exists_intro (Vars.union xs ys) (Sh.disj ps q) + + + let star_ats qf_star_ats at_fv = fun atl sh -> + let vs = List.fold (fun at vs -> Vars.union (at_fv at) vs) atl Vars.empty in + let xs, sh = exists_bind vs sh in + Sh.exists_intro xs (qf_star_ats atl sh) + + + module Pf = struct + let star = star_ats Sh.Pf.star E.fv + end + + module PtS = struct + let star = star_ats Sh.PtS.star Pt.fv + end +(* + module LsS = struct + let star = star_ats Sh.LsS.star Ls.fv + end + + module DjS = struct + let star = star_ats Sh.DjS.star Dj.fv + end +*) + module Jnk = struct + let star (xs,sh) = (xs, Sh.Jnk.star sh) + let remove (xs,sh) = (xs, Sh.Jnk.remove sh) + end + + + let normalize ?dnf ?(init=emp) xsh = + assert(true$> + L.incf 5 "( XSH.normalize:@ %a@]" fmt xsh); + (fun xsh' -> assert(true$> + L.decf 5 ") XSH.normalize:@ %a" fmt xsh')) + <& + Sh.normalize ?dnf ~init:(snd init) (exists_bind Vars.empty xsh) + + + let normalize_stem ?(init=emp) xsh = + assert(true$> + L.incf 5 "( XSH.normalize_stem:@ %a@]" fmt xsh); + (fun (xsh',_) -> assert(true$> + L.decf 5 ") XSH.normalize_stem:@ %a" fmt xsh')) + <& + Sh.normalize_stem ~init:(snd init) (exists_bind Vars.empty xsh) + + + let subst s q = + let s = S.restrict (fv q) s in + let xs, q = exists_bind (S.fv s) q in + let q' = Sh.subst s q in + exists_intro xs (inj q') + + + let rename_vs vs q = + let freshs, renaming, inverse = Sh.renaming vs in + (subst renaming q, freshs, renaming, inverse) + + + + (* Comparison Operations ================================================== *) + + let equal q r = q == r || equal_tup2 Vars.equal Sh.equal q r + + let compare q r = if q==r then 0 else compare_tup2 Vars.compare Sh.compare q r + +(* (** [alpha_equiv p q] holds only if [p] and [q] are alpha-equivalent *) *) +(* let alpha_equiv p q = *) +(* (* L.incf 10 "( alpha_equiv: %a %a" fmt p fmt q; *) *) +(* (* ( *) *) +(* let xs, p = exists_bind Vars.empty p in *) +(* let ys, q = exists_bind Vars.empty q in *) +(* let exists_p, exists_q = Vars.diff_diff xs ys in *) +(* if Vars.cardinal exists_p = Vars.cardinal exists_q then *) +(* let to_exp_list vs = Vars.fold (fun v el -> E.mkVar v :: el) vs [] in *) +(* let renamings = *) +(* List.map S.of_assoc *) +(* (List.fin_funs (to_exp_list exists_q) (to_exp_list exists_p)) in *) +(* let rec loop = function *) +(* | [] -> None *) +(* | renaming :: renamings -> *) +(* if Sh.equal p (Sh.subst renaming q) *) +(* then Some(renaming) *) +(* else loop renamings *) +(* in *) +(* loop renamings *) +(* else *) +(* None *) +(* (* ) &> *) *) +(* (* L.decf 10 ") alpha_equiv: %a" (fun ff -> function *) *) +(* (* | None -> Format.fprintf ff "false" *) *) +(* (* | Some(s) -> S.fmt ff s) *) *) + +(* + let equivalent p q = + if inconsistent p && inconsistent q then + Some(S.empty) + else + let q' = propagate p q in + match alpha_equiv p q' with + | None -> + let p' = propagate q p in + (* check p |- q' and q |- p' *) + let _, p = exists_bind (fv q') p in + let _, q' = exists_bind (Sh.fv p) q' in + let _, q = exists_bind (fv p') q in + let _, p' = exists_bind (Sh.fv q) p' in + if Pure.implies (Sh.pure_strong p) (Sh.pure q') + && Sh.equal (Sh.spatial p) (Sh.spatial q') + && Pure.implies (Sh.pure_strong q) (Sh.pure p') + && Sh.equal (Sh.spatial q) (Sh.spatial p') + then Some(S.empty) + else None + | some_renaming -> some_renaming +*) + let equivalent p q = if equal p q then Some(S.empty) else None +(* +(* let equal_coarse p q = equal p q || equivalent p q <> None *) + +(* let compare_coarse p q = *) +(* let ord = compare p q in *) +(* if ord = 0 || equivalent p q <> None then 0 else ord *) +*) + + + (* shadow ground values that cannot be exported from recursive module *) + let emp () = emp + let tt () = tt + let ff () = ff +end + + + +(*============================================================================ + Exported modules dethunking values + ============================================================================*) + +module SH = struct + include Sh + + let emp = emp() + let tt = tt() + let ff = ff() + +end + + +module XSH = struct + include XSh + + let emp = emp() + let tt = tt() + let ff = ff() + +end diff --git a/src/SymbolicHeap.mli b/src/SymbolicHeap.mli new file mode 100644 index 0000000..ea12da2 --- /dev/null +++ b/src/SymbolicHeap.mli @@ -0,0 +1,92 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Symbolic Heap formulas *) + +open Library + +open Variable +open Expression +open SYMBOLIC_HEAP + + +val normalize_tmr : Timer.t +val normalize_stem_tmr : Timer.t +val exists_elim_tmr : Timer.t +(* val map_fold_normalize_tmr : Timer.t *) +val pure_consequences_tmr : Timer.t +val labeled_pure_consequences_tmr : Timer.t + + + +(** Points-To formulas *) +module Pt : sig + type t = { loc: Exp.t; off: Off.t; cnt: Exp.t option } + include TERM with type t := t +end + + +(** Formal Parameters of List-Segment Patterns *) +module Params : (BIEDGE with type a = Var.t) + +(** Actual Arguments of List-Segment formulas *) +module Args : sig + include BIEDGE with type a = Exp.t + val cycle_eqs : t -> Exp.t list + val remove : bool -> t -> t -> t * t +end + +(** List-Segment Patterns *) +module rec Patn : sig + type t = private { params: Params.t; body: XSH.t; name: string } + include TERM with type t := t + val mk : ?name:string -> Params.t -> XSH.t -> t + val instantiate : t -> Args.t -> XSH.t +end + +(** List-Segment formulas. The ls predicate is defined by: + + ls(L,k,p,f,b,n) iff + k=0 * f=n * b=p + \/ ?i,j. k>0 * L(p,f,i,j) * ls(L,k-1,i,j,b,n) + + or equivalently: + k=0 * f=n * b=p + \/ ?i,j. k>0 * ls(L,k-1,p,f,i,j) * L(i,j,b,n) + + This justifies + + ls(L,k,p,f,i,j) * ls(L,l,i,j,b,n) |- ls(L,k+l,p,f,b,n) + and + L(p,f,b,n) |- ls(L,1,p,f,b,n) +*) +and Ls : sig + type t = { pat: Patn.t; len: Exp.t; arg: Args.t } + include TERM with type t := t + val empty_eqs : t -> Exp.t list + val fst_alloc : t -> Exp.t + val may_allocs : t -> Exp.t list + val direction : t -> Exp.t -> bool + val split_on_fresh_point : t -> Vars.t * Args.t * Args.t +end + + +(** Disjunctions, set of disjuncts each of which is a quantifier-free formula *) +and Dj : sig + include TERM + val fv : ?include_cng_rels:bool -> t -> Vars.t + include Set.R with type elt := SH.t and type t := t +end + + +(** (quantifier-free) Symbolic Heap formulas *) +and SH : + (QUANTIFIER_FREE_SYMBOLIC_HEAP + with type xsh := XSH.t + and type pt := Pt.t and type ls := Ls.t and type dj := Dj.t) + + +(** eXistentially quantified Symbolic Heap formulas *) +and XSH : + (EXISTENTIAL_SYMBOLIC_HEAP + with type sh := SH.t + and type pt := Pt.t and type ls := Ls.t and type dj := Dj.t) diff --git a/src/TRANSITIVE_RELATION.ml b/src/TRANSITIVE_RELATION.ml new file mode 100644 index 0000000..5074881 --- /dev/null +++ b/src/TRANSITIVE_RELATION.ml @@ -0,0 +1,41 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + + +module type TRANSITIVE_RELATION = sig + + type exp + (** Exps. *) + + type exps + (** Sets of exps. *) + + type t + (** A transitive relation representation [r: t] denotes a relation [[r]] + over a finite 'carrier' set of exps that is transitive. *) + + val empty : t + (** [[empty]] is the empty relation. *) + + val add : exp * exp -> t -> t + (** [[add (e,f) t]] is the smallest transitive relation containing [[t]] + and ([e],[f]). *) + + val add_scc : exps -> t -> t + + val inter : t -> t -> t + (** [[inter q r]] is the intersection of [[q]] and [[r]]. *) + +(* + val mem : t -> exp * exp -> bool + (** [mem r (e,f)] holds iff ([e],[f]) in [[r]]. *) +*) + val predecessors : t -> exp -> exps + (** [f] in [predecessors r e] iff ([f],[e]) in [[r]]. + Raises [Not_found] iff [e] not in the carrier of [r]. *) + + val is_reachable : (exp -> bool) -> t -> exp -> bool + + val fmt : Format.formatter -> t -> unit + + +end diff --git a/src/TYP.ml b/src/TYP.ml new file mode 100644 index 0000000..0d75399 --- /dev/null +++ b/src/TYP.ml @@ -0,0 +1,83 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library + + +module type TYP = sig + + type fld + + type t = t_desc HashCons.hc + + and t_desc = private + | Top (** universal type *) + | Named of string (** (recursive) reference to named structure/union *) + | Bool + | Int of bool * int (** unsigned, size *) + | Float of int (** size *) + | Pointer of t (** target *) + | Array of t * int64 option * int64 (** element type, length, size *) + | Structure of string * (fld * t) list * int64 (** name, members in declaration order, size *) + | Union of string * (fld * t) list * int64 (** name, members in declaration order, size *) + | Enum of string * (string * int) list * int64 (** name, enumerators, size *) + | Function of t * t list * bool (** result, arguments, vararg *) + + val desc : t -> t_desc + (** [desc t] is the descriptor named by type [t] *) + + val name : t_desc -> t + (** [name d] is the unique type name of descriptor [d] *) + + val id : t -> int + + val mkTop : t + val mkNamed : string -> t + val mkBool : t + val mkInt : bool -> int -> t + val mkFloat : int -> t + val mkPointer : t -> t + val mkArray : t -> int64 option -> int64 -> t + val mkStructure : string -> ((fld * t) list) -> int64 -> t + val mkUnion : string -> ((fld * t) list) -> int64 -> t + val mkEnum : string -> ((string * int) list) -> int64 -> t + val mkFunction : t -> (t list) -> bool -> t + + + val compare : t -> t -> int + val equal : t -> t -> bool + val equal_desc : t_desc -> t_desc -> bool + val hash : t -> int + + val fmt : t formatter + val fmt_caml : t formatter + + + val fst_flds : t -> fld list + + val all_paths : t -> ((int * int option) * fld list * t) list + (** [all_paths ty] is all the access paths through the type tree [ty], from + the root downwards to scalar leaves. The head of each path is the most + deeply nested field, and the list is in the same order as the fields are + defined. *) + + val all_offsets : t -> ((int * int option) * fld list * t) list + (** [all_offsets ty] is a list of all the access paths to distinct offsets through the type tree [ty], + from the root downwards to scalar leaves. The head of each path is the most deeply nested field, and + the list is in the same order as the fields are defined. *) + + val paths_at_offset : t -> (int * int option) -> (fld list * t) list + + val sizeof : t -> int64 + (** [sizeof t] is the number of bytes occupied by an object of type [t]. + Follows http://msdn.microsoft.com/en-us/library/cc953fe1.aspx. *) + + val find_by_name : string -> t option + (** [find_by_name name] returns the type named [name]. *) + + val of_fld : t -> fld -> t option + (** [of_fld t f] returns the type of the [f] field of type [t]. *) + + val fold_defined : (t -> 'z -> 'z) -> 'z -> 'z + (** [fold_defined] enumerates all currently defined types. *) + +end diff --git a/src/Timer.ml b/src/Timer.ml new file mode 100644 index 0000000..9a9dbe0 --- /dev/null +++ b/src/Timer.ml @@ -0,0 +1,98 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Timers for runtime statistics *) + +open Library + + +type t = { + mutable ustart: float; + mutable sstart: float; + mutable ufinish: float; + mutable sfinish: float; + mutable uduration: float; + mutable sduration: float; + mutable running: bool; + mutable pending: int; + mutable count: int; + mutable max: float; + mutable enabled: bool; + mutable name: string; +} + + +let init = + let {Unix.tms_utime; tms_stime} = Unix.times() in { + ustart= tms_utime; + sstart= tms_stime; + ufinish= 0.; + sfinish= 0.; + uduration= tms_utime; + sduration= tms_stime; + running= true; + pending= 0; + count= 0; + max= 0.; + enabled= true; + name= "init"; + } + +let create name = { + ustart= 0.; ufinish= 0.; uduration= 0.; + sstart= 0.; sfinish= 0.; sduration= 0.; + running= false; pending= 0; count= 0; max= 0.; + enabled= true; name; +} + +let enable t = t.enabled <- true +let disable t = t.enabled <- false + +let start t = + if not t.enabled then () else + if t.running then ( + t.pending <- t.pending + 1 ; + ) else ( + t.running <- true ; + let {Unix.tms_utime; tms_stime} = Unix.times() in + t.ustart <- tms_utime ; + t.sstart <- tms_stime ; + ) + +let stop t = + if not t.enabled then () else + if t.pending > 0 then ( + t.pending <- t.pending - 1 ; + ) else if t.running then ( + let {Unix.tms_utime; tms_stime} = Unix.times() in + t.running <- false ; + t.ufinish <- tms_utime; + t.sfinish <- tms_stime; + let ud = t.ufinish -. t.ustart + and sd = t.sfinish -. t.sstart in + t.uduration <- t.uduration +. ud ; + t.sduration <- t.sduration +. sd ; + let usd = ud +. sd in + if t.max < usd then t.max <- usd ; + t.count <- t.count + 1 ; + ) + +let stop_report t bound printf = + stop t ; + let {ustart; sstart; ufinish; sfinish; uduration; sduration} = t in + let elapsed = (ufinish +. sfinish) -. (ustart +. sstart) in + if elapsed > bound then printf elapsed (uduration +. sduration) + +let log tmr chan prefix = + let {ustart; sstart; ufinish; sfinish; count} = tmr in + output_string chan prefix ; + output_char chan '\t' ; + output_string chan (string_of_int count) ; + output_char chan '\t' ; + output_string chan (string_of_float (1000. *. ((ufinish +. sfinish) -. (ustart +. sstart)))) ; + output_char chan '\n' ; + flush chan + +let stop_ tmr () = stop tmr + +let time tmr fn = + start tmr ; try_finally fn (stop_ tmr) diff --git a/src/Timer.mli b/src/Timer.mli new file mode 100644 index 0000000..f882be3 --- /dev/null +++ b/src/Timer.mli @@ -0,0 +1,28 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Timers for runtime statistics *) + +type t = { + mutable ustart: float; + mutable sstart: float; + mutable ufinish: float; + mutable sfinish: float; + mutable uduration: float; + mutable sduration: float; + mutable running: bool; + mutable pending: int; + mutable count: int; + mutable max: float; + mutable enabled: bool; + mutable name: string; +} + +val init : t +val create : string -> t +val enable : t -> unit +val disable : t -> unit +val start : t -> unit +val stop : t -> unit +val stop_report : t -> float -> (float->float->unit) -> unit +val log : t -> out_channel -> string -> unit +val time : t -> (unit -> 'a) -> 'a diff --git a/src/TransRel.ml b/src/TransRel.ml new file mode 100644 index 0000000..c8a65ac --- /dev/null +++ b/src/TransRel.ml @@ -0,0 +1,358 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library + +open Expression + +let add_edge_tmr = Timer.create "TransRel.add_edge" +let add_scc_tmr = Timer.create "TransRel.add_scc" +let preds_tmr = Timer.create "TransRel.predecessors" + +module ExpTransRel = struct + type exp = Exp.t + type exps = Exps.t + + type uf = { + parent: exp ExpMap.t; + terms: ExpMMap.t; + rank: int ExpMap.t; + } + type tt = { + pred: ExpMMap.t; (** maps each exp to it's predecessors *) + succ: ExpMMap.t; (** maps each exp to it's succecessors *) + uf: uf; (** maps each exp to the representative of its strongly-connected component *) + } + type t = tt list (** the intersection of multiple relations *) + + let empty_uf = { + parent = ExpMap.empty; + terms = ExpMMap.empty; + rank = ExpMap.empty; + } + let empty = [{ + pred = ExpMMap.empty; + succ = ExpMMap.empty; + uf = empty_uf; + }] + + (* Successors and predessors are the same. *) + let same_succ_and_pred ms = + List.equal (fun (h,u) (k,v) -> Exp.equal h k && Exp.equal u v) + (ExpMMap.to_list ms.succ) + (ExpMMap.to_list (ExpMMap.fold (fun x y -> ExpMMap.add y x) ms.pred ExpMMap.empty)) + + (* Print representation of Transitive relation. *) + let fmt1 ff ms = + assert( same_succ_and_pred ms ); + let fmt_succ ff succ = + let fmt_exp_succs ff (exp,succs) = + Format.fprintf ff "@[(%a ->@ {@[%a@]})@]" Exp.fmt exp Exps.fmt succs + in + Format.fprintf ff "@[%a@]" (List.fmt "@ " fmt_exp_succs) + (ExpMMap.fold_keys (fun exp succs exp_succs -> (exp,succs) :: exp_succs) succ []) + in + let fmt_pred ff pred = + let fmt_exp_preds ff (exp,preds) = + Format.fprintf ff "@[(%a <-@ {@[%a@]})@]" Exp.fmt exp Exps.fmt preds + in + Format.fprintf ff "@[%a@]" (List.fmt "@ " fmt_exp_preds) + (ExpMMap.fold_keys (fun exp preds exp_preds -> (exp,preds) :: exp_preds) pred []) + in + let fmt_uf ff uf = + let fmt_rep_cls ff (rep,cls) = + Format.fprintf ff "@[(%a <->@ %a)@]" Exp.fmt rep (Exps.fmt_sep " <->@ ") cls + in + Format.fprintf ff "@[%a@]" (List.fmt "@ " fmt_rep_cls) + (ExpMMap.fold_keys (fun rep cls rep_cls -> (rep,cls) :: rep_cls) uf.terms []) + in + Format.fprintf ff "@[@[Succ:@ %a@]@ @[Pred:@ %a@]@ @[SCCs:@ %a@]@]" + fmt_succ ms.succ fmt_pred ms.pred fmt_uf ms.uf + + let fmt ff mss = + Format.fprintf ff "%a" (List.fmt "@; /\\ " fmt1) mss + + let rec find uf e = + (* Representatives don't have a parent *) + match ExpMap.tryfind e uf.parent with + | Some e' -> find uf e' + | None -> e + + let rank uf e = + match ExpMap.tryfind e uf.rank with + | Some n -> n + | None -> 0 (* We use 0 as the initial rank *) + + let terms uf e = + Exps.add e (ExpMMap.find e uf.terms) + + let union_set es uf = + let first = Exps.choose es in + let es' = Exps.remove first es in + (* Find the max rank of the equivalence class to choose the representative. + If there are more than one with the max, remember so we can add one to the rank. *) + let max_rank, rep, multiple = + Exps.fold (fun e (rnk,elt,mlt) -> + let rnk' = rank uf e in + if rnk' > rnk then + (rnk', e, false) + else if rnk' = rnk then + (rnk, elt, true) + else + (rnk, elt, mlt) + ) es' (rank uf first, first, false) + in + let es = Exps.remove rep es in + (* Increase rank if combining with something of same rank *) + let rank = + if multiple then ExpMap.add rep (max_rank+1) (uf.rank) + else uf.rank in + (* Update the parents to point to the representative, and add all their children to the set *) + let (parent,terms) = + Exps.fold (fun e (pa,re)-> + (ExpMap.add e rep pa, + ExpMMap.remove e (ExpMMap.union rep (Exps.add e (ExpMMap.find e re)) re)) + ) es (uf.parent,uf.terms) in + let uf = {parent = parent; terms = terms; rank= rank} in + (uf, rep) + + + let only_representatives ms = + (* Assumes same_succ_pred has been called, so don't need to check the range of succ or the preds. *) + ExpMMap.fold_keys (fun k _ b -> b && (Exp.equal k (find ms.uf k))) ms.succ true + + let invariant ms = + assert( same_succ_and_pred ms ); + assert( only_representatives ms ) + + (* Combines all of the vertices in eqs into one vertex*) + let merge eqs m = + let preds = m.pred in + let succs = m.succ in + let uf,r = union_set eqs m.uf in + + (* Remove all the nodes from the preds and succs, and add the succs and preds to the equivalence class's*) + let rest = Exps.remove r eqs in + let all_ nodes = + Exps.fold (fun e -> Exps.union (Exps.diff (ExpMMap.find e nodes) rest)) + eqs (Exps.empty) in + let all_succs = Exps.add r (all_ succs) in + let all_preds = Exps.add r (all_ preds) in + let succs = + Exps.fold (fun e m -> (*ExpMMap.diff e (Exps.singleton e)*) + (ExpMMap.union e all_succs + (ExpMMap.diff e rest m)) + ) all_preds succs in + let preds = + Exps.fold (fun e m -> (*ExpMMap.diff e (Exps.singleton e)*) + (ExpMMap.union e all_preds + (ExpMMap.diff e rest m)) + ) all_succs preds in + let succ = Exps.fold ExpMMap.remove rest succs in + let pred = Exps.fold ExpMMap.remove rest preds in + { pred; succ; uf } + + + let floydWarshall preds succs = + ExpMMap.fold_keys (fun mid _ (preds,succs) -> + (* Note, the second param is almost su_mid, but has not been updated *) + let pr_mid = ExpMMap.find mid preds in + let su_mid = ExpMMap.find mid succs in + (* Just add cross product of edges *) + let preds = Exps.fold (fun k -> ExpMMap.union k pr_mid) su_mid preds in + let succs = Exps.fold (fun k -> ExpMMap.union k su_mid) pr_mid succs in + ( preds, succs) + ) succs (preds,succs) + + + (** [[add (e,f) t]] is the smallest transitive relation containing [[t]] and ([e],[f]). *) + let add_inner (s,e) m = + assert(true$> + invariant m ); + (fun m' -> assert( + invariant m' ; + let s = find m.uf s in + let e = find m.uf e in + let pred'', succ'' = floydWarshall (ExpMMap.add e s m.pred) (ExpMMap.add s e m.succ) in + let pred' = m'.pred in + let b = + ExpMMap.fold_keys (fun k xs b -> + let ys = ExpMMap.find k pred'' in + let xs_all = Exps.unions ((terms m'.uf k)::(List.map (terms m'.uf) (Exps.to_list xs))) in + let ys_all = Exps.unions ((terms m.uf k)::(List.map (terms m.uf) (Exps.to_list ys))) in + if Exps.equal xs_all ys_all then b else let()=()in + Format.printf "k:@\n @{%a@]@\nxs_all : @\n @[%a@]@\nys_all:@\n @[%a@]@\n" + Exp.fmt k Exps.fmt xs_all Exps.fmt ys_all ; + Format.printf "Pre:@\n @[%a@]@\nPost@\n @[%a@]@\nFW@\n @[%a@]@\n" + fmt [m] fmt [m'] fmt [{pred=pred''; succ=succ''; uf = m.uf}] ; + assert false + ) pred' true in + b + || (Format.printf "Start @\n%a@\nNew existing@\n%a@\nFW@\n%a@\n" + fmt [m] fmt [m'] fmt [{pred=pred'';succ=succ'';uf=m.uf}] ; + false) + )) <& + let s = find m.uf s in + let e = find m.uf e in + let preds = m.pred in + let succs = m.succ in + (* If s and e are currently equal, or the edge already exists do noting *) + if Exp.equal s e || Exps.mem s (ExpMMap.find e preds) then + m + else + (* Otherwise add the edges and the transitive new edges *) + let pr_s = Exps.add s (ExpMMap.find s preds) in + let su_e = Exps.add e (ExpMMap.find e succs) in + if Exps.mem e pr_s then + (* We are creating a cycle so do the UF work *) + (* Any node that is both a succ of e and pred of s, will be made equal by this update *) + let eqs = Exps.inter su_e pr_s in + (* Add eqs to UF *) + let eqs = Exps.add s (Exps.add e eqs) in + merge eqs m + else + (* Just add cross product of edges *) + let pred = Exps.fold (fun k -> ExpMMap.union k pr_s) su_e preds in + let succ = Exps.fold (fun k -> ExpMMap.union k su_e) pr_s succs in + { m with pred; succ } + + + let predecessors_inner s m = + let s = find m.uf s in + Exps.fold (fun p ps -> + Exps.union ps (terms m.uf p) + ) (ExpMMap.find s m.pred) (terms m.uf s) + + let predecessors ms e = + Timer.start preds_tmr ; (fun _ -> Timer.stop preds_tmr) <& + Exps.inters (List.map (predecessors_inner e) ms) + + let inter xs ys = + (* Just check if there are the same structures multiple times *) + List.fold (fun x rs -> if List.memq x ys then rs else x::rs) xs ys + + let is_reachable p rg x = + List.for_all (fun m -> + Exps.exists p (predecessors_inner x m) + ) rg + + let add (s,e) ms = + Timer.start add_edge_tmr ; (fun _ -> Timer.stop add_edge_tmr) <& + List.map (add_inner (s,e)) ms + + let add_scc_list_no_opt xs rg = + let rec add_scc_list_ xs rg = + match xs with + | x::y::zs -> add_scc_list_ (y::zs) (add_inner (x,y) (add_inner (y,x) rg)) + | _ -> rg in + add_scc_list_ xs rg + + + let add_scc_list_inner xs rg = + invariant rg ; (fun rg' -> invariant rg') <& + (* MJP: Not sure which is faster, I think option 2, but left + alternatives for further profiling, when I have chance *) + let option = 2 in + match option with + | 0 -> + add_scc_list_no_opt xs rg + | 1 -> + merge (List.fold (fun e -> Exps.add (find rg.uf e)) xs Exps.empty) rg + | 2 -> + let no_edges, has_edges = + List.fold (fun x (no_edges,has_edges) -> + let x = find rg.uf x in + if ExpMMap.mem x rg.pred || ExpMMap.mem x rg.succ then + (no_edges, Exps.add x has_edges) + else + (Exps.add x no_edges, has_edges) + ) xs (Exps.empty,Exps.empty) in + let edges, uf = + match Exps.cardinal no_edges with + | 0 -> + (has_edges, rg.uf) + | 1 -> + (Exps.add (Exps.choose no_edges) has_edges, rg.uf) + | _ -> + let uf, r = union_set no_edges rg.uf in + (Exps.add r has_edges, uf) + in + let rg = {rg with uf} in + (match Exps.cardinal edges with + | 0 | 1 -> rg + | _ -> merge edges rg + ) + | _ -> + let no_edges,has_edges = + List.fold (fun x (no_edges,has_edges) -> + let x = find rg.uf x in + if ExpMMap.mem x rg.pred || ExpMMap.mem x rg.succ then + (no_edges, Exps.add x has_edges) + else + (Exps.add x no_edges, has_edges) + ) xs (Exps.empty,Exps.empty) in + let has_edges = Exps.to_list has_edges in + let edges, uf = + match Exps.cardinal no_edges with + | 0 -> + (has_edges, rg.uf) + | 1 -> + ((Exps.choose no_edges)::has_edges, rg.uf) + | _ -> + let uf, r = union_set no_edges rg.uf in + (r::has_edges, uf) in + let rg = {rg with uf = uf} in + add_scc_list_no_opt edges rg + + + let add_scc_list xs rg = + Timer.start add_scc_tmr ; (fun _ -> Timer.stop add_scc_tmr) <& + List.map (add_scc_list_inner xs) rg + + let add_scc xs rg = + if Exps.cardinal xs > 1 then + add_scc_list (Exps.to_list xs) rg + else + rg + + + let fmt ff mss = + let car r = + Exps.empty + |> + ExpMMap.fold_keys (fun e' es car -> + Exps.add e' (Exps.union es car) + ) r.uf.terms + |> + ExpMMap.fold_keys (fun s ps car -> + Exps.add s (Exps.union ps car) + ) r.pred + in + let preds s r = + predecessors_inner s r + in + let fold fn r z = + Exps.fold (fun s z -> + Exps.fold (fun p z -> + fn p s z + ) (preds s r) z + ) (car r) z + in + let mem p s r = + Exps.mem (find r.uf p) (preds s r) + in + let inter q r = + fold (fun p s i -> + if mem p s r then + add_inner (p,s) i + else + i + ) q (List.hd empty) + in + let inters = function + | [] -> List.hd empty + | [r] -> r + | r::rs -> List.fold inter rs r + in + Format.fprintf ff "%a" fmt1 (inters mss) + +end diff --git a/src/TransformProgram.ml b/src/TransformProgram.ml new file mode 100644 index 0000000..4dca30b --- /dev/null +++ b/src/TransformProgram.ml @@ -0,0 +1,362 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library +open Type + +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.vPgm : Log.LOG) + + +let normalize_tmr = Timer.create "TransformProgram.normalize" + + +(*========================================================================================================== + Transform programs so that formals are not modified + ==========================================================================================================*) + +let eliminate_modified_formals prog = + Prog.map_procs (fun ({Proc.id; formals; locals; cfg; entry} as proc) -> + let ms = + CFG.fold_edges (fun _ ms -> ms) (fun (_,c,_) ms -> + match c with + | C.Inst({I.desc= (I.Load(v,_) | I.Alloc(v,_) | I.Move(v,_) | I.Cast(v,_,_))}) -> + Vars.add v ms + | C.Inst({I.desc= I.Kill(vs)}) -> + Vars.union vs ms + | C.Inst({I.desc= (I.Store _ | I.Free _ | I.Assume _ | I.Assert _ | I.Nop | I.Generic _)}) + | C.Call _ + | C.ICall _ -> + ms + ) cfg (K.id entry) Vars.empty + in + let formals, moves, locals = + List.fold_right (fun f (fs, moves, locals) -> + if Vars.mem f ms then + let f' = Var.gensym (Var.name f) (Var.sort f) in + let mv = I.mk (I.Move(f, E.mkVar f')) (K.pos entry) in + (f' :: fs, mv :: moves, Vars.add f locals) + else + (f :: fs, moves, locals) + ) formals ([], [], locals) + in + let prefix_blk blk entry = + let rec prefix_blk_ blk entry = + match blk with + | inst :: (_::_ as blk) -> + let vtx = CFG.add_vertex cfg (K.mk_label inst.I.pos id) in + CFG.add_edge cfg vtx (C.Inst(inst)) entry ; + prefix_blk_ blk vtx + | [inst] -> + let vtx = CFG.add_vertex cfg (K.mk_label ~sort:K.Entry inst.I.pos id) in + CFG.add_edge cfg vtx (C.Inst(inst)) entry ; + vtx + | [] -> + entry + in + let entry' = prefix_blk_ blk entry in + if blk <> [] && K.sort entry <> None then + ignore( CFG.relabel_vertex cfg entry (K.set_sort (CFG.label_of entry) None) ); + entry' + in + let entry = prefix_blk moves entry + in + {proc with Proc.formals; locals; entry} + ) prog + + +(*========================================================================================================== + Normalize programs wrt nop being the identity of sequential composition + ==========================================================================================================*) + +let concat_blocks g v0 = + L.incf 10 "( concat_blocks" ; L.decf 10 ") concat_blocks" $> + let visited = CFG.VertexISet.create () + in + let collapse_pre_ok v w = + match K.sort v , K.sort w with + | _ , None + | Some(K.Entry | K.Cut | K.Join), Some(K.Join | K.Fork) + | Some(K.Return) , Some(K.Fork) -> true + + | Some(K.Return) , Some(K.Join) + | _ , Some(K.Exit | K.Return | K.Cut) + | None , Some(K.Join | K.Fork) -> false + + | Some(K.Fork) , _ -> failwith "only called when v has 1 succ" + + | Some(K.Exit) , _ + | _ , Some(K.Entry) -> failwith "concat_blocks: malformed CFG" + in + let collapse_post_ok v w = + match K.sort v , K.sort w with + | None , _ + | Some(K.Join | K.Fork) , Some(K.Exit | K.Cut | K.Join) + | Some(K.Fork) , Some(K.Return | K.Fork) -> true + + | Some(K.Join) , Some(K.Return | K.Fork) + | Some(K.Entry | K.Return | K.Cut), _ + | Some(K.Join | K.Fork) , None -> false + + | Some(K.Exit) , _ + | _ , Some(K.Entry) -> failwith "concat_blocks: malformed CFG" + in + let concat_ok w = + match K.sort w with + | None -> true + | Some(K.Return | K.Cut | K.Join) -> false + | Some(K.Fork) -> failwith "only called when w has 1 succ" + | Some(K.Entry | K.Exit) -> failwith "concat_blocks: malformed CFG" + in + let rec start v = + L.printf 10 "start: %a" CFG.Vertex.fmt v ; + if not (CFG.VertexISet.mem visited v) then + match CFG.successors v with + | [(w, (C.Inst({I.desc= I.Nop}) as c))] when collapse_pre_ok v w -> + CFG.collapse_edge_pre g v c w ; + start v + | succs -> + CFG.VertexISet.add visited v ; + List.iter (fun (w,c) -> continue v c w) succs + and continue v c w = + L.printf 10 "continue: @[%a@]@ @[%a@]@ @[%a@]" CFG.Vertex.fmt v C.fmt c CFG.Vertex.fmt w ; + match CFG.successors w with + | [] when collapse_post_ok v w -> + (match c with + | C.Inst({I.desc= I.Nop}) -> + CFG.collapse_edge_post g v c w + | _ -> () + ) + | [(x, (C.Inst({I.desc= I.Nop}) as d))] when collapse_post_ok w x -> + CFG.collapse_edge_post g w d x ; + continue v c x + | [(x, d)] when concat_ok w -> + (match C.append c d with + | Some(cd) -> + L.printf 10 "@[appending@ @[%a@]@ to @[%a@]@]" C.fmt c C.fmt d ; + CFG.add_edge g v cd x ; + CFG.remove_edge g v c w ; + CFG.remove_edge g w d x ; + CFG.remove_vertex g w ; + continue v cd x + | None -> + start w + ) + | _ -> + start w + in + start v0 + + +(*========================================================================================================== + Normalize programs so that control point sorts accurately reflect flow graph structure + ==========================================================================================================*) + +let fmt_nbrs nbrs ff v = + (List.fmt ";@ " CFG.Vertex.fmt) ff (List.map fst (nbrs v)) + +let set_sorts ({Proc.cfg; entry; exit} as proc) = + let set_sort v sort = + if K.sort v = sort then + v + else + CFG.relabel_vertex cfg v (K.set_sort (CFG.label_of v) sort) + in + let cs = CFG.cutpoints entry + in + assert( + (not (CFG.VertexSet.mem entry cs) + || L.warnf "entry point a cutpoint") + && (CFG.in_degree entry = 0 + || L.warnf "entry point %a@ has predecessors:@ %a" CFG.Vertex.fmt entry (fmt_nbrs CFG.predecessors) entry) + && (not (CFG.VertexSet.mem exit cs) + || L.warnf "exit point a cutpoint") + && (CFG.out_degree exit = 0 + || L.warnf "exit point %a@ has successors:@ %a" CFG.Vertex.fmt exit (fmt_nbrs CFG.successors) exit) + ); + let entry = set_sort entry (Some(K.Entry)) in + assert( CFG.in_degree entry = 0 || L.warnf "entry point has predecessors: %a" CFG.Vertex.fmt entry ) + ; + let exit = set_sort exit (Some(K.Exit)) in + assert( CFG.out_degree exit = 0 || L.warnf "exit point has successors: %a" CFG.Vertex.fmt exit ) + ; + let cs = CFG.cutpoints entry + in + CFG.iter_vertices (fun v -> + if not (CFG.Vertex.equal exit v) then + let in_degree = CFG.in_degree v in + let out_degree = CFG.out_degree v in + if CFG.VertexSet.mem v cs then ignore @@ set_sort v (Some(K.Cut)) + else if in_degree > 1 then ignore @@ set_sort v (Some(K.Join)) + else if out_degree > 1 then ignore @@ set_sort v (Some(K.Fork)) + else if in_degree = 0 then assert( CFG.Vertex.equal entry v || L.warnf "entry point not unique" ) + else ignore @@ set_sort v None + ) cfg + ; + CFG.iter_edges (fun _ -> ()) (fun (_,c,v) -> + match c with + | C.Inst _ -> + assert( (K.sort v <> Some(K.Return) || L.warnf "return point not preceded by call") ) + | C.Call _ + | C.ICall _ -> + assert( (not (CFG.VertexSet.mem v cs) || L.warnf "return point a cutpoint") + && (CFG.in_degree v = 1 || L.warnf "return point has multiple predecessors: %a" CFG.Vertex.fmt v) + && (CFG.out_degree v = 1 || L.warnf "return point has multiple successors: %a" CFG.Vertex.fmt v) ); + ignore( set_sort v (Some(K.Return)) ) + ) cfg (CFG.index_of entry) + ; + {proc with Proc.entry; exit} + + +(*========================================================================================================= + Compute callee's for each call-site + =========================================================================================================*) + +let compute_call_targets prog = + (* Really should calculate using a may-alias analysis, for now use types *) + let open Cmnd in + let open Proc in + let open Prog in + Prog.iter_procs (fun _ {Proc.entry; cfg} -> + CFG.iter_edges + (fun _ -> ()) + (fun (c,e,n) -> + match e with + | Inst _ -> + () + | Call{Call.proc; targets} -> + assert( match targets with [target] -> Proc.Id.equal target proc | _ -> false ); + | ICall({Call.typ; targets= targets0} as call) -> + let targets = + if not Config.optimize_icall_targets then + prog.addr_taken + else + List.filter (fun pid -> + let p = Proc.IdHMap.find prog.procs pid in + (*Format.printf "%a =?= %a@\n" Typ.fmt p.fty Typ.fmt ic.typ;*) + Typ.equal (Typ.mkPointer p.fty) typ + ) prog.addr_taken in + if not (List.equal Proc.Id.equal targets targets0) then ( + CFG.remove_edge cfg c e n ; + CFG.add_edge cfg c (ICall{call with Call.targets}) n ; + ) + ) cfg (K.id entry) + ) prog ; + prog + + +(*========================================================================================================== + Compute modified and accessed variables + ==========================================================================================================*) + +module PMM = MultiMap.Make (Proc.Id) (Vars) + +(* MJP: Quite inefficient, could calc each procedure, and then use + transitive call graph to get the rest *) +let compute_variables prog f = + let {Prog.globals} = prog in + (* initial base to calculate the direct values *) + let m = + Prog.fold_procs (fun {Proc.id; cfg; entry} -> + CFG.fold_edges (fun _ m -> m) (fun (_,tr,_) m -> + PMM.union id (f tr) m + ) cfg (K.id entry) + ) prog PMM.empty + in + (* Keep pushing around the call graph, should be cleverer here *) + let rec loop m = + let m' = + Prog.fold_procs (fun {Proc.id; cfg; entry} m -> + CFG.fold_edges (fun _ m -> m) (fun (_,c,_) m -> + match c with + | C.Inst _ -> + m + | C.Call{Call.targets} + | C.ICall{Call.targets} -> + assert( targets <> [] + || failwith "compute_call_targets must precede compute_variables" ); + List.fold (fun target m -> + PMM.union id (Vars.inter globals (PMM.find target m)) m + ) targets m + ) cfg (K.id entry) m + ) prog m in + if PMM.length m = PMM.length m' then m else loop m' + in + loop m + + +let compute_modified_variables ({Prog.procs; globals} as prog) = + let m = compute_variables prog C.mv in + let procs = + Proc.IdHMap.mapi (fun pid proc -> + {proc with Proc.modifs= Vars.inter globals (PMM.find pid m)} + ) procs + in + {prog with Prog.procs} + +let compute_accessed_variables ({Prog.procs; globals} as prog) = + let m = compute_variables prog C.fv in + let procs = + Proc.IdHMap.mapi (fun pid proc -> + {proc with Proc.accessed= Vars.inter globals (PMM.find pid m)} + ) procs + in + {prog with Prog.procs} + +let compute_local_variables ({Prog.procs; globals} as prog) = + let m = compute_variables prog C.fv in + let procs = + Proc.IdHMap.mapi (fun pid ({Proc.formals; freturn} as proc) -> + let nonlocals = List.fold Vars.add formals (Option.fold Vars.add freturn globals) in + {proc with Proc.locals= Vars.diff (PMM.find pid m) nonlocals} + ) procs + in + {prog with Prog.procs} + + + +(*========================================================================================================== + Normalize programs + ==========================================================================================================*) + +let normalize_cfg prog = + Prog.map_procs (fun ({Proc.entry; exit; cfg} as proc) -> + CFG.root_vertex cfg entry ; + CFG.root_vertex cfg exit ; + CFG.remove_unreachable cfg ; + let ({Proc.entry; cfg} as proc) = set_sorts proc in + concat_blocks cfg entry ; + proc + ) prog + +let normalize prog = + L.incf 1 "( TransformProgram.normalize" ; + Timer.start normalize_tmr ; + (fun _ -> + Timer.stop normalize_tmr ; + L.decf 1 ") TransformProgram.normalize" + )<& let()=()in + prog |> + compute_call_targets |> + (* compute_accessed_variables depends on call targets having been computed *) + compute_accessed_variables |> + (* remove_unused_globals depends on accessed variables having been computed, and global_setup not yet inlined *) + RemoveUnusedGlobals.remove_unused_globals |> + normalize_cfg |> + (* inline depends on control point sorts having been set *) + Inline.prog |> + (* fewer variables are formals after inlining *) + eliminate_modified_formals |> + Livevars.liveness_prog |> + normalize_cfg |> + compute_local_variables |> + compute_modified_variables |> + compute_accessed_variables |> + id diff --git a/src/TransformProgram.mli b/src/TransformProgram.mli new file mode 100644 index 0000000..e8f6fd4 --- /dev/null +++ b/src/TransformProgram.mli @@ -0,0 +1,8 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Program + +val normalize : Prog.t -> Prog.t + + +val normalize_tmr : Timer.t diff --git a/src/Type.ml b/src/Type.ml new file mode 100644 index 0000000..3baab10 --- /dev/null +++ b/src/Type.ml @@ -0,0 +1,404 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Types for determining object layout *) + +(* Review: + 1. Top currently used to break cycles in typedefs; + 2. Enum and Function probably not needed. +*) + +open Library + +open FLD +open TYP +module HC = HashCons + +module L = (val Log.std Config.vTyp : Log.LOG) + + +(*============================================================================ + Fld + ============================================================================*) + +module rec Fld : sig + type t = { id: int; off: int * int option; name: string; mutable typ: Typ.t } + include FLD with type typ := Typ.t and type t := t + val fmt_off : (int * int option) formatter +end = +struct + + type t = { id: int; off: int * int option; name: string; mutable typ: Typ.t } + (* Fld.t values are cyclic: f.typ is the type of which f is a member *) + + include UniqueId.Make(struct + type data = (int * int option) * string * Typ.t + type uniq = t + let get {id} = id + let set id (off, name, typ) = {id; off; name; typ} + end) + + let compare x y = let c = Pervasives.compare x.off y.off in if c <> 0 then c else compare x y + + let off x = x.off + let name x = x.name + let typ x = x.typ + + let is_first x = + match x.off with + | (0, None) | (0, Some(0)) -> true + | _ -> false + + let mk off name = gensym (off, name, Typ.mkTop) + let unsafe_create id off name typ = unsafe_create id (off, name, typ) + + + let find_by_name ty name = + try + match Typ.desc ty with + | Typ.Structure(_,fld_tys,_) | Typ.Union(_,fld_tys,_) -> + Some(List.find (fun (f,_) -> f.name = name) fld_tys) + | _ -> + raise Not_found + with Not_found -> None + + + let fmt_off ff (byt_off, bit_off) = + match bit_off with + | Some(bit_off) -> Format.fprintf ff "%i.%i" byt_off bit_off + | None -> Format.fprintf ff "%i" byt_off + + let fmt ff v = + match !Config.vTyp with + | 0 -> Format.fprintf ff "%s:%a" (Hooks.var_name v.name) fmt_off v.off + | 1 -> Format.fprintf ff "%s:%a" v.name fmt_off v.off + | _ -> Format.fprintf ff "%s:%a!%i" v.name fmt_off v.off v.id + + let fmt_caml _ff _ = + failwith "ToDo: Fld.fmt_caml" + +end + + + +(*============================================================================ + Typ + ============================================================================*) + +and Typ : (TYP with type fld := Fld.t) = struct + + type t = t_desc HC.hc + + and t_desc = + | Top + | Named of string + | Bool + | Int of bool * int + | Float of int + | Pointer of t + | Array of t * int64 option * int64 + | Structure of string * (Fld.t * t) list * int64 + | Union of string * (Fld.t * t) list * int64 + | Enum of string * (string * int) list * int64 + | Function of t * t list * bool + + let id t = t.HC.id + let desc e = e.HC.desc + + + (* Formatting ============================================================= *) + + let rec fmt_desc_ deep ff = function + | Named s -> Format.fprintf ff "@[%s@]" s + | Top -> Format.fprintf ff "@[Top@]" + | Bool -> Format.fprintf ff "@[bool@]" + | Int(u,s) -> Format.fprintf ff "@[%sint%i@]" (if u then "u" else "") s + | Float(s) -> Format.fprintf ff "@[float%i@]" s + | Pointer(t) -> Format.fprintf ff "@[%a *@]" (fmt_ false) t + | Array(t,None,_) -> Format.fprintf ff "@[%a[]@]" (fmt_ deep) t + | Array(t,Some(l),_) -> Format.fprintf ff "@[%a[%Ld]@]" (fmt_ deep) t l + | ( Structure(id,fldty,_) + | Union(id,fldty,_) ) as t -> + let fldty_fmt ff (fld,ty) = Format.fprintf ff "@[%a@ %a@]" (fmt_ deep) ty Fld.fmt fld in + if not deep || !Config.vTyp <= 1 then Format.fprintf ff "%s" id else + Format.fprintf ff "@[%s %s@ {@[ %a@]@ }@]" + (match t with Structure _ -> "struct" | Union _ -> "union" | _ -> assert false) + id + (List.fmt ";@ " (fun ff fldty -> fldty_fmt ff fldty)) fldty + | Enum(id,idval,_) -> + let idval_fmt ff (id,v) = Format.fprintf ff "@[%s = %d@]" id v in + if !Config.vTyp <= 1 then Format.fprintf ff "%s" id else + Format.fprintf ff "@[enum %s { %a }@]" + id (List.fmt ";@ " idval_fmt) idval + | Function(retty,args,vararg) -> + Format.fprintf ff "@[(%a)(FUNC)(%a%s)@]" + (fmt_ deep) retty (List.fmt ";@ " (fmt_ deep)) args (if vararg then ",..." else "") + + and fmt_ deep ff t = + fmt_desc_ deep ff (desc t) + + let fmt_desc ff t = fmt_desc_ true ff t + + let fmt ff t = + match !Config.vTyp with + | 0 -> () + | 1 -> Format.fprintf ff "@[(%a)@]" (fmt_ true) t + | _ -> Format.fprintf ff "@[%i:(%a)@]" t.HC.id (fmt_ true) t + + + let rec fmt_caml ff t = + match desc t with + | Named(s) -> Format.fprintf ff "@[(Typ.mkNamed %s)@]" s + | Top -> Format.fprintf ff "@[Typ.mkTop@]" + | Bool -> Format.fprintf ff "@[Typ.mkBool@]" + | Int(u,s) -> Format.fprintf ff "@[Typ.mkInt %b %i@]" u s + | Float(s) -> Format.fprintf ff "@[Typ.mkFloat %i@]" s + | Pointer(t) -> Format.fprintf ff "@[(Typ.mkPointer %a)@]" fmt_caml t + | Array(t,None,s) -> Format.fprintf ff "@[(Typ.mkArray %a None %Li)@]" fmt_caml t s + | Array(t,Some(l),s) -> Format.fprintf ff "@[(Typ.mkArray %a (Some(%Li)) %Li)@]" fmt_caml t l s + | (Structure(id,fldty,size) + | Union(id,fldty,size)) as t -> + let fldty_fmt_caml ff (fld,ty) = + Format.fprintf ff "@[(%a,@ %a)@]" Fld.fmt_caml fld fmt_caml ty in + Format.fprintf ff "@[%s@ \"%s\"@ [@[%a@]]@ %Li@]" + (match t with + | Structure _ -> "Typ.mkStructure" + | Union _ -> "Typ.mkUnion" + | _ -> assert false) + id + (List.fmt ";@ " (fun ff fldty -> fldty_fmt_caml ff fldty)) fldty + size + | Enum(id,idval,size) -> + let idval_fmt_caml ff (id,v) = + Format.fprintf ff "@[(\"%s\",%d)@]" id v in + Format.fprintf ff "@[(Typ.mkEnum \"%s\"@ %a@ %Li@]" + id (List.fmt ";@ " (fun ff idval -> idval_fmt_caml ff idval)) idval size + | Function(retty,args,vararg) -> + Format.fprintf ff "@[(Typ.mkFunction %a@ [%a]@ %s)@]" + fmt_caml retty (List.fmt ";@ " fmt_caml) args + (if vararg then "true" else "false") + + + (* Comparison ============================================================= *) + + let rec hash_desc x = + match x with + | Pointer(t) -> + Hashtbl.hash (1 + hash t) + | Array(t,l,s) -> + Hashtbl.hash (hash t, l, s) + | Structure(n,fs,s) | Union(n,fs,s) -> + Hashtbl.hash (n, List.map (fun (f,t) -> (Fld.id f, hash t)) fs, s) + | Function(r,ps,v) -> + Hashtbl.hash (hash r, List.map hash ps, v) + | Top | Bool | Int _ | Float _ | Enum _ | Named _ -> + Hashtbl.hash x + + and hash x = x.HC.hash + &> (fun n -> assert( n = hash_desc x.HC.desc || failwithf "mis-hashed: %a" fmt x )) + + (* The equality relation passed to HashCons.Make is used on shallow copies of possibly-dead values, so + physical disequality and disequality of ids cannot be relied upon. *) + let rec equal_desc x y = + (fun eq -> assert( + (not eq || hash_desc x = hash_desc y + || failwithf "@[hash %a = %i <> %i = hash %a@]" fmt_desc x (hash_desc x) (hash_desc y) fmt_desc y) )) + <& + let equal x y = + (x == y) || (x.HC.id = y.HC.id) || (equal_desc x.HC.desc y.HC.desc) + in + (x == y) || + match x, y with + | Top, Top + | Named _, Named _ + | Bool, Bool + | Int _, Int _ + | Float _, Float _ + | Enum _, Enum _ -> + x = y + | Pointer(s), Pointer(t) -> + equal s t + | Array(t,m,i), Array(u,n,j) -> + i = j && m = n && equal t u + | Structure(n,fs,i), Structure(m,gs,j) + | Union(n,fs,i), Union(m,gs,j) -> + i = j + && n = m + && List.equal (fun (f,s) (g,t) -> Fld.equal f g && equal s t) fs gs + | Function(r,ps,u), Function(s,qs,v) -> + u = v && equal r s && List.equal equal ps qs + | ( Top | Bool | Int _ | Float _ | Pointer _ + | Array _ | Structure _ | Union _ | Enum _ | Function _ | Named _), _ -> + false + + let equal x y = (x == y) + &> (fun ptr_eq -> assert( + let id_eq = (x.HC.id = y.HC.id) in + let desc_eq = equal_desc x.HC.desc y.HC.desc in + let hash_eq = (hash x = hash y) in + (not ptr_eq || hash_eq + || failwithf "@[hash %a = %i != %i = hash %a@]" fmt x (hash x) (hash y) fmt y) && + (ptr_eq = id_eq + || failwithf "@[%a %s %a@]" fmt x (if ptr_eq then "== but id <>" else "!= but id =") fmt y) && + (id_eq = desc_eq + || failwithf "@[%a %s %a@]" fmt x (if id_eq then "id = but desc <>" else "id <> but desc =") fmt y) && + (desc_eq = ptr_eq + || failwithf "@[%a %s %a@]" fmt x (if ptr_eq then "== but desc <>" else "!= but desc =") fmt y) )) + + let compare x y = Pervasives.compare x.HC.id y.HC.id + &> (fun cmp -> assert( + (cmp <> 0 || hash x = hash y + || failwithf "@[hash %a = %i <> %i = hash %a@]" fmt x (hash x) (hash y) fmt y) && + ((cmp = 0) = (equal_desc x.HC.desc y.HC.desc) + || failwithf "@[%a@ %s@ %a@]" fmt x (if cmp = 0 then "= but <>" else "<> but =") fmt y) )) + + + (* Hash-Consing =========================================================== *) + + module Desc = struct + type t = t_desc + let equal x y = equal_desc x y + let hash x = hash_desc x + let fmt = fmt_desc + end + + module HCTbl = HC.Make(Desc) + + let tbl = HCTbl.create Config.typ_hc_initial_size + + let name d = HCTbl.intern tbl d + + + (* Desc Constructors ====================================================== *) + + let mkTop = name Top + let mkBool = name Bool + let mkInt u s = name (Int(u,s)) + let mkFloat s = name (Float(s)) + let mkPointer t = name (Pointer(t)) + let mkNamed t = name (Named(t)) + let mkArray t l s = name (Array(t,l,s)) + let mkEnum n ts s = name (Enum(n,ts,s)) + let mkFunction r ps v = name (Function(r,ps,v)) + + let set_field_typs ty fs = List.iter (fun (fld,_) -> fld.Fld.typ <- ty) fs + + let mkStructure n fs s = + let ty = name (Structure(n,fs,s)) in + set_field_typs ty fs ; + assert( ty == name (Structure(n,fs,s)) ); + ty + + let mkUnion n fs s = + let ty = name (Union(n,fs,s)) in + set_field_typs ty fs ; + assert( ty == name (Union(n,fs,s)) ); + ty + + + (* Queries ================================================================ *) + + let fst_flds t = + match desc t with + | Structure(_,ftys,_) | Union(_,ftys,_) -> + List.fold (fun (f,_) fs -> if Fld.is_first f then f :: fs else fs) ftys [] + | _ -> + [] + + + let fmt_path ff path = Format.fprintf ff "%a" (List.fmt ";@ " Fld.fmt) path + let fmt_path_t ff (off,path,t) = Format.fprintf ff "@[(%a,@ %a,@ %a)@]" Fld.fmt_off off fmt_path path fmt t + + let off_add (x,n) (y,i) = + assert( n = None || failwithf "Unexpected aggregate bit-field" ); + (x+y, i) + + let all_paths t = + assert(true$>( L.incf 10 "( all_paths:@ %a" fmt t )); + (fun z -> assert(true$>( L.decf 10 ") @[%a@]" (List.fmt ";@ " fmt_path_t) z ))) + <& + let rec path off prefix t results = + match desc t with + | Structure(_id,fty,_) | Union(_id,fty,_) -> + List.fold_right (fun (f,t) pp -> path (off_add off (Fld.off f)) (f :: prefix) t pp) fty results + | Bool | Int _ | Float _ | Pointer _ | Array _ | Enum _ | Function _ -> + (off, prefix, t) :: results + | Top | Named _ -> + results + in + path (0,None) [] t [] + + + let all_offsets t = + assert(true$>( L.shift_verb (!Config.vTyp - 2) (fun () -> L.incf 10 "( all_offsets:@ %a" fmt t ))); + (fun z -> assert(true$>( L.decf 10 ") @[%a@]" (List.fmt ";@ " fmt_path_t) z ))) + <& + let rec path off prefix t results = + match desc t with + | Structure(_,fty,_) -> + List.fold_right (fun (f,t) pp -> path (off_add off (Fld.off f)) (f :: prefix) t pp) fty results + | Union(_,(f,t) :: _,_) -> + path (off_add off (Fld.off f)) (f :: prefix) t results + | Union(_,[],_) -> + results + | Bool | Int _ | Float _ | Pointer _ | Array _ | Enum _ | Function _ -> + if List.exists (fun (o,_,_) -> off = o) results then + results + else + (off, prefix, t) :: results + | Top | Named _ -> + results + in + path (0,None) [] t [] + + + let paths_at_offset ty off = + List.fold (fun (o,path,ty) paths -> + if o = off + then (path, ty) :: paths + else paths + ) (all_offsets ty) [] + + + let sizeof typ = + assert(true$>( L.incf 10 "( sizeof: %a" fmt typ )); (fun z -> assert(true$>( L.decf 10 ") %Li" z ))) + <& + match desc typ with + | Top | Named _ -> + 0L + | Bool -> + 1L + | Int(_,s) | Float(s) -> + Int64.of_int s + | Pointer(_) | Function(_) | Array(_,None,_) -> + Int64.of_int Config.ptr_size + | Array(_,_,s) | Enum(_,_,s) | Structure(_,_,s) | Union(_,_,s) -> + s + + + let of_fld typ fld = + match desc typ with + | Structure(_,fld_tys,_) | Union(_,fld_tys,_) -> + (try Some(List.assoc fld fld_tys) with Not_found -> None) + | _ -> + None + + + let fold_defined fn z = + HCTbl.fold fn tbl z + + + let find_by_name name = + let module M = struct exception Found of Typ.t end in let open M in + try + fold_defined (fun ty () -> + match desc ty with + | Structure(ty_id,_,_) | Union (ty_id,_,_) when ty_id = name -> + raise (Found(ty)) + | _ -> () + ) () ; + raise Not_found + with + | Found(ty) -> Some(ty) + | Not_found -> None + +end diff --git a/src/Type.mli b/src/Type.mli new file mode 100644 index 0000000..2b62c0b --- /dev/null +++ b/src/Type.mli @@ -0,0 +1,11 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Types for determining object layout *) + +open FLD +open TYP + + +module +rec Fld : (FLD with type typ := Typ.t) +and Typ : (TYP with type fld := Fld.t) diff --git a/src/UniqueId.ml b/src/UniqueId.ml new file mode 100644 index 0000000..a7cb2c2 --- /dev/null +++ b/src/UniqueId.ml @@ -0,0 +1,58 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Unique Identifiers *) + +open Library + +module L = (val Log.std Config.vFE : Log.LOG) + + +module type S = sig + type data + type uniq + + val compare : uniq -> uniq -> int + val equal : uniq -> uniq -> bool + val hash : uniq -> int + (* val fmt : uniq formatter *) + + val id : uniq -> int + val gensym : data -> uniq + + val marshal : out_channel -> unit + val unmarshal : in_channel -> unit + + val unsafe_create : int -> data -> uniq +end + +module Make (M: sig + type data + type uniq + val get : uniq -> int + val set : int -> data -> uniq +end) = +struct + type data = M.data + type uniq = M.uniq + + let compare x y = Pervasives.compare (M.get x) (M.get y) + let equal x y = Pervasives.( = ) (M.get x) (M.get y) + let hash x = Hashtbl.hash (M.get x) + + let id x = M.get x + + let initial = 0 + let count = ref initial + let gensym x = incr count ; M.set !count x + let unsafe_create id data = count := max !count id; M.set id data + + let marshal chan = + L.printf 100 "UniqueId.marshal %i" !count ; + Marshal.to_channel chan !count [] + + let unmarshal chan = + (fun()-> L.printf 100 "UniqueId.unmarshal %i" !count) <& let()=()in + (* unmarshaling makes no attempt to preserve uniqueness, so assumes none are already constructed *) + assert( !count = initial ); + count := (Marshal.from_channel chan) +end diff --git a/src/UniqueId.mli b/src/UniqueId.mli new file mode 100644 index 0000000..ea0e5b7 --- /dev/null +++ b/src/UniqueId.mli @@ -0,0 +1,29 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Unique Identifiers *) + + +module type S = sig + type data + type uniq + + val compare : uniq -> uniq -> int + val equal : uniq -> uniq -> bool + val hash : uniq -> int + + val id : uniq -> int + val gensym : data -> uniq + + val marshal : out_channel -> unit + val unmarshal : in_channel -> unit + + val unsafe_create : int -> data -> uniq +end + +module Make (M: sig + type data + type uniq + val get : uniq -> int + val set : int -> data -> uniq +end) : +(S with type uniq = M.uniq and type data = M.data) diff --git a/src/UnitTests/Frame_test.ml b/src/UnitTests/Frame_test.ml new file mode 100644 index 0000000..78f155d --- /dev/null +++ b/src/UnitTests/Frame_test.ml @@ -0,0 +1,119 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library + +open Expression +module E = Exp +open SymbolicHeap +module D = Discovery + +let log = Log.std Prover.verbose +let printf x = Log.printf log x + +let fmt lab ff (us,p,xs,q) = + Format.fprintf ff "%s@[: @[%a%a@]@\n\\ @[%a%a@]@]" lab + (Vars.fmt_embrace "@[! " " .@]@ ") us SH.fmt p + (Vars.fmt_embrace "@[? " " .@]@ ") xs SH.fmt q + + +(*============================================================================ + Test running + ============================================================================*) + +let test_reachable name expect xs_sh rootset e = + let _,sh = XSH.exists_bind Vars.empty xs_sh in + let keep l = Exps.mem l rootset in + let sh, closure = Reachability.reachable keep sh in + let is_reachable l = + keep l || Exps.mem l (closure sh) + in + (try Printexc.print (fun()-> is_reachable e) () + with exc -> if !Config.stop then raise exc else not expect + )|> + (fun b -> printf 0 "%s: %s" name (if b = expect then "PASS" else "FAIL")) + + + + + +(*============================================================================ + Tests + ============================================================================*) + +open Prover_test + + +let test () = + printf 0 "testing Frame.reachable" ; + +(* let _d = [E.Pos,E.mkFld(Var.gensym "D" ())] in *) +(* let _o = [E.Pos,E.mkFld(Var.gensym "O" ())] in *) +(* let _flink = [E.Pos,E.mkFld(Var.gensym "Flink" ())] in *) + + let f' = Var.gensym "f" E.OffsetSort in let _f = E.mkVar f' in + let g' = Var.gensym "g" E.ValueSort in let g = E.mkVar g' in + let j' = Var.gensym "j" E.ValueSort in let j = E.mkVar j' in + let k' = Var.gensym "k" E.ValueSort in let _k = E.mkVar k' in + let l' = Var.gensym "l" E.ValueSort in let _l = E.mkVar l' in + let r' = Var.gensym "r" E.RecordSort in let _r = E.mkVar r' in + let r0' = Var.gensym "r0" E.RecordSort in let r0 = E.mkVar r0' in + let r1' = Var.gensym "r1" E.RecordSort in let r1 = E.mkVar r1' in + let v' = Var.gensym "v" E.ValueSort in let _v = E.mkVar v' in + let w' = Var.gensym "w" E.ValueSort in let w = E.mkVar w' in + let x = E.mkVar (Var.gensym "x" E.ValueSort) in + let y = E.mkVar (Var.gensym "y" E.ValueSort) in + let z' = Var.gensym "z" E.ValueSort in let z = E.mkVar z' in + + (* + PS #375 01/10/2009 23:33, with h_12/y, h_49/g, i_11/j, t_25/x, t_27/z: + q = { ? g, y . z==y * j=(y+1) * (0<=(-y+3)) * x->[] * z->[+F: g] * g->[+F: x] } + Check: g \in (reachable q {x,z}) + *) + let y_eq_2 = eq y (E.mkNum 2) (* was y <= 3*) and + j_eq_yplus1 = eq j (E.mkZAdd [y; E.mkNum 1]) and + z_eq_y = eq z y in + let q = + (XSH.starx [z_eq_y; j_eq_yplus1; y_eq_2; pt x ; ptF z g ] + (ptF g x)) in + test_reachable "test 1" true q (Exps.of_list [x; z]) g ; + +(* + PS #375 05/11/2009 16:37, with r_15/y, n_11/x, de_13/g, nS-_17/j, r_34/w, r_35/z: + + q = + { ? w, r_41, r_58, f_65, r_80 . + y==x * z==g * 0==j * (y!=0) * (w!=0) * (z!=0) * + w->[r_80; +IDL+F: z+IDD; +IDL+B: z+IDD] * z->[r_58; +IDD+B: w+IDL; +IDD+F: w+IDL] } + + Check: w \in (reachable q {z}). +*) + let y_eq_x = eq y x and + z_eq_g = eq z g and + j_eq_0 = eq E.zero j and + y_ne_0 = dq y E.zero and + w_ne_0 = dq w E.zero and + z_ne_0 = dq z E.zero in + let w_obj = + let idl_f = E.mkAdd [E.mkFld(Var.gensym "F" ()); E.mkFld(Var.gensym "IDL" ())] in + let idl_b = E.mkAdd [E.mkFld(Var.gensym "B" ()); E.mkFld(Var.gensym "IDL" ())] in + E.mkUpd + (E.mkUpd r0 idl_f (E.mkOff z (E.mkFld(Var.gensym "IDD" ())))) + idl_b + (E.mkOff z (E.mkFld(Var.gensym "IDD" ()))) + in + let z_obj = + let idd_b = E.mkAdd [E.mkFld(Var.gensym "B" ()); E.mkFld(Var.gensym "IDD" ())] in + let idd_f = E.mkAdd [E.mkFld(Var.gensym "F" ()); E.mkFld(Var.gensym "IDD" ())] in + E.mkUpd + (E.mkUpd r1 idd_b (E.mkOff w (E.mkFld(Var.gensym "IDL" ())))) + idd_f + (E.mkOff w (E.mkFld(Var.gensym "IDL" ()))) + in + let q = + XSH.star [ y_eq_x; z_eq_g; j_eq_0; y_ne_0; w_ne_0; z_ne_0 ] + (SH.PtS.star [Pt.mk (w,w_obj); Pt.mk (z,z_obj)] SH.emp) + in + test_reachable "test 2" true q (Exps.of_list [z]) w ; + + + () diff --git a/src/UnitTests/Frame_test.mli b/src/UnitTests/Frame_test.mli new file mode 100644 index 0000000..ad648b7 --- /dev/null +++ b/src/UnitTests/Frame_test.mli @@ -0,0 +1,3 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +val test : unit -> unit diff --git a/src/UnitTests/Graph_test.ml b/src/UnitTests/Graph_test.ml new file mode 100644 index 0000000..10d96bc --- /dev/null +++ b/src/UnitTests/Graph_test.ml @@ -0,0 +1,62 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library + + +(* Tracing ================================================================== *) + +module L = struct + let log = Log.std Graph.verbose + let printf l x = Log.printf log l x + let incf l x = Log.incf log l ("@["^^x^^"@]") + let decf l x = Log.decf log l ("@["^^x^^"@]") + let warnf x = Log.warnf log ("@["^^x^^"@]") + let errorf x = Log.errorf log ("@["^^x^^"@]") +end + + +(* Test #1: (add_edge; remove_edge) should be id. *) +module Nodes = struct + type t = int + let compare = Pervasives.compare + let equal x y = (x=y) + let hash = Hashtbl.hash + let fmt ff = Format.fprintf ff "%d" +end + +module Edges = struct + type t = string + let compare = Pervasives.compare + let equal x y = (x = y) + let fmt ff = Format.fprintf ff "%s" +end +module G = Graph.Make (Nodes) (Nodes) (Edges) + +let test1 _ = + begin + let g = G.create () in + G.clear g; + let src, tgt = 1,100 in + let vtx_src = G.add_vertex g src src in + let vtx_tgt = G.add_vertex g tgt tgt in + let lbl = "1_2_skipafew_99_100" in + G.add_edge g vtx_src lbl vtx_tgt ; + let result_add = + if (G.mem_edge g vtx_src lbl vtx_tgt) + then (L.printf 1 "Graph_test#1: edge added, OK" ; true) + else (L.printf 1 "Graph_test#1: edge not added, FAIL!" ; false) + in + G.remove_edge g vtx_src lbl vtx_tgt ; + let result_remove = + if (G.mem_edge g vtx_src lbl vtx_tgt) + then (L.printf 1 "Graph_test: edge found, FAIL!" ; false) + else (L.printf 1 "Graph_test: edge not found, OK" ; true) + in + result_add && result_remove + end + + + +let test _ = + L.printf 0 "testing Graph" ; + assert (test1 ()) diff --git a/src/UnitTests/Graph_test.mli b/src/UnitTests/Graph_test.mli new file mode 100644 index 0000000..ad648b7 --- /dev/null +++ b/src/UnitTests/Graph_test.mli @@ -0,0 +1,3 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +val test : unit -> unit diff --git a/src/UnitTests/Prover_test.ml b/src/UnitTests/Prover_test.ml new file mode 100644 index 0000000..5ed8c07 --- /dev/null +++ b/src/UnitTests/Prover_test.ml @@ -0,0 +1,297 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library + +open Expression +module E = Exp +open SymbolicHeap +module D = Discovery + +let log = Log.std Prover.verbose +let printf x = Log.printf log x + +let fmt lab ff (us,p,xs,q) = + Format.fprintf ff "%s@[: @[%a%a@]@\n\\ @[%a%a@]@]" lab + (Vars.fmt_embrace "@[! " " .@]@ ") us SH.fmt p + (Vars.fmt_embrace "@[? " " .@]@ ") xs SH.fmt q + + +(*============================================================================ + Test running + ============================================================================*) + +(* Note: This is quite crude: only checks whether subtract fails or not, we + could also check the: + - number of distinct remainders found + - remainders found are the expected ones + - number of duplicate proofs of each remainder + - size of the proof search space explored (Prover.try_count) +*) +let test_subtract name expect p q = + let ys, p = XSH.exists_bind (XSH.fv q) p in + let xs, q = XSH.exists_bind (Vars.union (SH.fv p) ys) q in ( + try Printexc.print (fun()-> Prover.subtract p xs q <> Prover.Failure) () + with exc -> if !Config.stop then raise exc else not expect + )|> + (fun b -> printf 0 "%s: %s" name (if b = expect then "PASS" else "FAIL")) + + +let test_entails name expect xs p q = + (Prover.entails p xs q <> None) + |> + (fun b -> printf 0 "%s: %s" name (if b = expect then "PASS" else "FAIL")) + +let test_entailsx name expect p q = + (Prover.entailsx p q <> None) + |> + (fun b -> printf 0 "%s: %s" name (if b = expect then "PASS" else "FAIL")) + + + +(*============================================================================ + Tests + ============================================================================*) + +let eq x y = XSH.Pf.star [E.mkEq x y] XSH.emp + +let dq x y = XSH.Pf.star [E.mkDq x y] XSH.emp + +let pt a = + let r = Var.gensym "r" E.RecordSort in + SH.exists_intro (Vars.singleton r) (SH.PtS.star [Pt.mk (a, E.mkVar r)] SH.emp) + +let ptV a r = XSH.PtS.star [Pt.mk (a, E.mkVar(r))] XSH.emp + +let ptF a c = + let r = Var.gensym "r" E.RecordSort in + SH.exists_intro (Vars.singleton r) + (SH.PtS.star [Pt.mk (a, E.mkUpd (E.mkVar r) (E.mkFld(Var.gensym "Flink" ())) c)] SH.emp) + +let sll l f n = + XSH.exists_intro (Vars.singleton l) + (XSH.LsS.star + [{Ls.pat= !!D.sll; + len= E.mkVar l; + arg= {Ends.fore=[(f,(Type.Top,E.eps),n)]; back=[]}}] + XSH.emp) + + +let ls patn len fore back = + (patn, len, {Ends.fore= fore; back=back}, Exps.empty) + + + +let test () = + printf 0 "testing Prover" ; + + let d = E.mkFld(Var.gensym "D" ()) in + let o = E.mkFld(Var.gensym "O" ()) in + let flink = E.mkFld(Var.gensym "Flink" ()) in + let f' = Var.gensym "f" E.OffsetSort in let f = E.mkVar(f') in + let g' = Var.gensym "g" E.OffsetSort in let _g = E.mkVar(g') in + let j' = Var.gensym "j" E.ValueSort in let _j = E.mkVar j' in + let k' = Var.gensym "k" E.ValueSort in let k = E.mkVar k' in + let l' = Var.gensym "l" E.ValueSort in let l = E.mkVar l' in + let r' = Var.gensym "r" E.RecordSort in let r = E.mkVar r' in + let r0' = Var.gensym "r0" E.RecordSort in let r0 = E.mkVar r0' in + let r1' = Var.gensym "r1" E.RecordSort in let r1 = E.mkVar r1' in + let v' = Var.gensym "v" E.ValueSort in let v = E.mkVar v' in + let w' = Var.gensym "w" E.ValueSort in let w = E.mkVar w' in + let x = E.mkVar (Var.gensym "x" E.ValueSort) in + let y = E.mkVar (Var.gensym "y" E.ValueSort) in + let z' = Var.gensym "z" E.ValueSort in let z = E.mkVar z' in + + (* { x->[F: y] * y->[F: z] * z->[] } \ ? l . { ls(sll,l,,x.,,x) } *) + let p = XSH.starx [ptF x y; ptF y z; pt z] XSH.emp in + let q = sll l' x x in + test_subtract "test 1" true p q ; + + (* { x->[F: y] * y->[F: z] * z->[] } \ ? l . { ls(sll,l,,x.,,y) } *) + let p = XSH.starx [ptF x y; ptF y z; pt z] XSH.emp in + let q = sll l' x y in + test_subtract "test 2" true p q ; + + (* { ls(sll,k,,x.,,y) * y->[F: z] } \ ? l . { ls(sll,l,,x.,,z) } *) + let p = XSH.starx [sll k' x y] (ptF y z) in + let q = sll l' x z in + test_subtract "test 3" true p q ; + + (* { ls(sll,j,,x.,,y) * ls(sll,k,,y.,,z) } \ ? l . { ls(sll,l,,x.,,z) } *) + let p = XSH.starx [sll j' x y] (sll k' y z) in + let q = sll l' x z in + test_subtract "test 4" true p q ; + + (* { ls(sll,l,,x.,,y) * y->[] } \ { x->[] } *) + let p = XSH.starx [sll l' x y] (pt y) in + let q = pt x in + test_subtract "test 5" true p q ; + + (* { ls(sll,l,,x.,,y) * y->[] } \ ? r . { x->r } *) + let p = XSH.starx [sll l' x y] (pt y) in + let q = ptV x r' in + let q = XSH.exists_intro (Vars.singleton r') q in + test_subtract "test 6" true p q ; + + (* { ls(sll,l,,x.,,y) * y->[] } \ ? w . { x->[F: w] } *) + let p = XSH.starx [sll l' x y] (pt y) in + let q = ptF x w in + let q = XSH.exists_intro (Vars.singleton w') q in + test_subtract "test 7" true p q ; + + (* { ls(sll,l,,x.,,y) * y->[F: v] } \ ? w . { x->[F: w] } *) + let p = XSH.starx [sll l' x y] (ptF y v) in + let q = ptF x w in + let q = XSH.exists_intro (Vars.singleton w') q in + test_subtract "test 8" true p q ; + + (* { ls(sll,l,,x.,,y) * y->[F: v] } \ ? r,f. { x+D-f->r } *) + let p = XSH.starx [sll l' x y] (ptF y v) in + let xdf = E.mkOff (E.mkOff x d) (E.mkMin f) in + let q = ptV xdf r' in + let q = XSH.exists_intro (Vars.of_list [r';f']) q in + test_subtract "test 9" true p q ; + + (* { ls(sll,l,,x.,,y) * y->[D: w; F: v] } \ ? r,f. { x+D-f->r } *) + let p = XSH.starx [sll l' x y; ptF y v] (pt z) in + let q = XSH.starx [ptF x w] (pt z) in + let q = XSH.exists_intro (Vars.singleton w') q in + test_subtract "test 10" true p q ; + + (* { (y!=0) * y->[r_92; +F: x] * ls(sll,k,,x.,,0) } + \ ? l . { ls(sll,l,,y.,,x) } *) + let p = XSH.starx [dq x E.nil; ptF y x] (sll k' x E.nil) in + let q = sll l' y x in + test_subtract "test 11" true p q ; + + (* { x->r0 * { y==x * 0==k } \/ { l=(k-1) * y->r1 * ls(sll,l,,r0.+F.,,y) } } + \ ? r . { x->r } *) + let p0 = XSH.starx [eq y x] (eq E.zero k) + and p1 = XSH.starx [pt y; + sll l' (E.mkSel r0 flink) y] + (eq l (E.mkZSub [k; E.mkNum 1])) in + let p = XSH.starx [XSH.disj p0 p1] (ptV x r0') + in + let q = pt x + in + test_subtract "test 12" true p q ; + + (* { { y==x * y->r0 } \/ { x->r0 } } \ ? r . { x->r } *) + let p0 = XSH.starx [eq x y] (pt y) + and p1 = pt x in + let p = XSH.disj p0 p1 in + let q = pt x in + test_subtract "test 13" true p q ; + + (* { r0.+f-D+F==y * + { z==x * D==f * [r4; +F: z]==r0 * z->r2 } \/ + { z==x * D==f * z->r3 } } + \ ? r1, g . { x+F-g->r1 } *) + let r0fDF = E.mkSel r0 (E.mkAdd [E.mkFld (Var.gensym "F" ()); E.mkMin (E.mkFld (Var.gensym "D" ())); E.mkVar f']) in + let p = + XSH.Pf.star [E.mkEq r0fDF y] + (XSH.disj + (XSH.Pf.star + [E.mkEq z x; + E.mkEq (E.mkFld((Var.gensym "D" ()))) (E.mkVar(f')); + E.mkEq (E.mkUpd r (E.mkFld((Var.gensym "F" ()))) z) r0] + (pt z)) + (XSH.Pf.star + [E.mkEq z x; + E.mkEq (E.mkFld((Var.gensym "D" ()))) (E.mkVar(f'))] + (pt z))) + in + let q = + XSH.exists_intro (Vars.singleton g') + (pt (E.mkOff x (E.mkAdd [E.mkMin (E.mkVar g'); E.mkFld (Var.gensym "F" ())]))) in + + test_subtract "test 14" true p q ; + + (* { x==r1.+D * r1==[r0; +F: y] } \ { x==r0.+D==r1.+D * r1==[r0; +F: y] } *) + let p = + XSH.Pf.star + [E.mkEq x (E.mkSel r1 (E.mkFld((Var.gensym "D" ())))); + E.mkEq r1 (E.mkUpd r0 (E.mkFld((Var.gensym "F" ()))) y); + E.mkDq (E.mkFld (Var.gensym "D" ())) (E.mkFld (Var.gensym "F" ()))] + XSH.emp in + let q = + XSH.Pf.star + [E.mkEq x (E.mkSel r0 (E.mkFld((Var.gensym "D" ()))))] + p in + test_subtract "test 15" true p q ; + + (* { x->[r0; O+F: y] } \ ? z, r1 . { x->[r1; O+F: z+O] } *) + let p = + XSH.Pf.star [E.mkDq (E.mkFld (Var.gensym "F" ())) (E.mkFld (Var.gensym "O" ()))] <| + XSH.PtS.star [Pt.mk (x, E.mkUpd r0 (E.mkAdd [E.mkFld (Var.gensym "O" ()); E.mkFld (Var.gensym "F" ())]) y)] XSH.emp + and q = + XSH.exists_intro (Vars.of_list [z'; r1']) + (XSH.PtS.star + [Pt.mk (x, E.mkUpd r0 (E.mkAdd [E.mkFld (Var.gensym "O" ()); E.mkFld (Var.gensym "F" ())]) + (E.mkOff z (E.mkFld((Var.gensym "O" ())))))] + XSH.emp ) + in + test_subtract "test 16" true p q ; + + (* { x==y-O * x->r0 } \ ? f, r1 . { y+B-f->r1 } *) + let p = + XSH.Pf.star [E.mkDq (E.mkFld (Var.gensym "F" ())) (E.mkFld (Var.gensym "O" ()))] <| + XSH.starx [eq x (E.mkOff y (E.mkMin o))] (pt x) + and q = + XSH.exists_intro (Vars.of_list [f']) + (pt (E.mkOff y (E.mkAdd [E.mkFld (Var.gensym "B" ()); E.mkMin (E.mkVar f')])) ) + in + test_subtract "test 17" true p q ; + + (* { [+IDD+F]==f * v[+F-f]->[r; [+f]: w] } + \ ? v, w. { [+IDD+F]==f * v[+F-f]->[r; [+f]: w] } *) + let idd_f = (E.mkAdd [E.mkFld (Var.gensym "F" ()); E.mkFld (Var.gensym "IDD" ())]) in + let vFf = E.mkOff v (E.mkAdd [E.mkMin (E.mkVar f'); E.mkFld (Var.gensym "F" ())]) in + let q = + XSH.exists_intro (Vars.of_list [v';w']) + (XSH.Pf.star [E.mkEq idd_f f] + (XSH.PtS.star + [Pt.mk (vFf, E.mkUpd r (E.mkVar(f')) w)] + XSH.emp) ) + in + let p = XSH.Pf.star [E.mkDq (E.mkFld (Var.gensym "F" ())) (E.mkFld (Var.gensym "IDD" ()))] q + in + test_subtract "test 18" true p p ; + + (* \? w. w->[] * v->[] |- v->[] * tt *) + let p = XSH.exists_intro (Vars.singleton w') (pt w) in + let q = pt v in + let p_q = XSH.starx [p] q in + let q_tt = XSH.starx [q] XSH.tt in + test_subtract "test 19" true p_q q_tt ; + + (* Like test #18, but the equality is inside the disjuncts. + + { ? v, w. v[+F-f]->[r; [+f]: w] * + ([+IDD+F]==f * x->_) \/ ([+IDD+F]==f * y->_) } + + (The pts are there to force the equalities to stay inside the disjuncts.) *) + let idd_f = (E.mkAdd [E.mkFld (Var.gensym "F" ()); E.mkFld (Var.gensym "IDD" ())]) in + let vFf = E.mkOff v (E.mkAdd [E.mkMin (E.mkVar f'); E.mkFld (Var.gensym "F" ())]) in + let idd_f_eq_f = XSH.Pf.star [E.mkEq idd_f f] XSH.emp in + let p = + XSH.exists_intro (Vars.of_list [v';w']) + (XSH.PtS.star + [ Pt.mk (vFf, E.mkUpd r (E.mkVar(f')) w) ] + (XSH.disj (XSH.starx [idd_f_eq_f] (pt x)) + (XSH.starx [(pt y)] idd_f_eq_f)) ) + in + test_subtract "test 20" true p p ; + + (* { (+F = +f) ^ x+F-f->[] } \ { x->[] } *) + let p = + XSH.Pf.star + [E.mkEq (E.mkFld (Var.gensym "F" ())) f; + E.mkEq (E.mkAdd [E.mkMin (E.mkVar f'); E.mkFld (Var.gensym "F" ())]) + (E.mkAdd [E.mkMin (E.mkVar g'); E.mkFld (Var.gensym "G" ())])] + (pt (E.mkOff (E.mkOff x (E.mkFld (Var.gensym "F" ()))) (E.mkMin f))) + in + let q = pt x + in + test_subtract "test 21" true p q ; + + () diff --git a/src/UnitTests/Prover_test.mli b/src/UnitTests/Prover_test.mli new file mode 100644 index 0000000..ba68a47 --- /dev/null +++ b/src/UnitTests/Prover_test.mli @@ -0,0 +1,15 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Expression +open SymbolicHeap + + +val test : unit -> unit + + +val eq : Exp.value -> Exp.value -> XSH.t +val dq : Exp.value -> Exp.value -> XSH.t +val pt : Exp.value -> XSH.t +val ptV : Exp.value -> Exp.var -> XSH.t +val ptF : Exp.value -> Exp.value -> XSH.t +val sll : Exp.var -> Exp.value -> Exp.value -> XSH.t diff --git a/src/UnitTests/TestGen.ml b/src/UnitTests/TestGen.ml new file mode 100644 index 0000000..2bf676e --- /dev/null +++ b/src/UnitTests/TestGen.ml @@ -0,0 +1,56 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(* Utility code to generate stand-alone unit tests *) + +open Library + +open Variable +open Expression +module E = Exp +open Program + + +let constants = ref [] +let globals = ref Vars.empty + +let _ = Initialize.register (fun {Prog.constants= c; globals= g} -> + constants := c ; + globals := g ; +) + + +let gen name fmt_test = + (* delay until exit to avoid clobbering the exception backtrace *) + Pervasives.at_exit (fun()-> + let filename = name ^ "_" ^ Config.testname ^ ".ml" in + let chan = open_out filename in + let ff = Format.formatter_of_out_channel chan in + Format.pp_set_margin ff Config.margin; + Format.kfprintf (fun ff -> Format.pp_print_flush ff (); close_out chan) + ff + "open Library@\n\ + open Variable@\n\ + open Expression@\n\ + module E = Exp@\n\ + open SymbolicHeap@\n\ + open SIL@\n\ + module D = Discovery@\n\ + let _ =@\n\ + ignore( Config.parse () );@\n\ + @[let types = []@]@\nin@\n\ + @[let constants = [@,@[%a@]]@]@\nin@\n\ + @[let globals = @[%a@]@]@\nin@\n\ + @[let name = \"\"@]@\nin@\n\ + @[let formals = []@]@\nin@\n\ + @[let locals = Vars.empty@]@\nin@\n\ + @[let modifs = Vars.empty@]@\nin@\n\ + @[let cfg = Cont.dummy@]@\nin@\n\ + @[let exit = Cont.dummy@]@\nin@\n\ + @[let main = @[{Proc.name; formals; locals; modifs; cfg; exit@]@]@\nin@\n\ + @[let program = @[{Prog.types; constants; globals; main}@]@\nin@\n\ + Initialize.initialize program;@\n\ + %t@\n" + (List.fmt ";@ " (fun ff c -> Format.pp_print_string ff (Int64.to_string c))) !constants + Vars.fmt_caml !globals + fmt_test + ) diff --git a/src/UnitTests/TestGen.mli b/src/UnitTests/TestGen.mli new file mode 100644 index 0000000..d025d6e --- /dev/null +++ b/src/UnitTests/TestGen.mli @@ -0,0 +1,6 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Utility code to generate stand-alone unit tests *) + + +val gen : string -> (Format.formatter -> unit) -> unit diff --git a/src/UnitTests/TestGenProver.ml b/src/UnitTests/TestGenProver.ml new file mode 100644 index 0000000..97a2d76 --- /dev/null +++ b/src/UnitTests/TestGenProver.ml @@ -0,0 +1,80 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(* Utility code to generate stand-alone unit tests *) + +open Library + +open Variable +open Expression +module E = Exp +open SymbolicHeap + + +let gen_query (id, kind, (_us, minuend, xs, subtrahend)) = + match kind with + | "subtract" -> + TestGen.gen ("sub_" ^ (string_of_int id)) (fun ff -> + Format.fprintf ff + "let tmr = Timer.create() in Timer.start tmr ;@\n\ + try let result =@\n\ + @[Prover.subtract_count@\n\ + @[%a@]@\n@\n\ + @[(Vars.of_list [@[%a@]])@]@\n@\n\ + @[%a@]@]@\n\ + in@\n\ + Timer.stop Timer.init ;@\n\ + Statistics.report (Timer.create()) tmr (Timer.create()) ;@\n\ + Printf.printf \"RESULT: %%i\\n\" result@\n\ + @\n\ + with exc ->@\n\ + print_endline (\"\\nRESULT: Internal Error: \"^\ + (Printexc.to_string exc)) ;@\n\ + flush_all () ;@\n\ + raise exc" + SH.fmt_caml minuend + (List.fmt ";@ " Var.fmt_caml) (Vars.to_list xs) + SH.fmt_caml subtrahend + ) + | "entails" -> + TestGen.gen ("ent_" ^ (string_of_int id)) (fun ff -> + Format.fprintf ff + "let tmr = Timer.create() in Timer.start tmr ;@\n\ + try let result =@\n\ + @[Prover.entails@\n\ + @[%a@]@\n@\n\ + @[(Vars.of_list [@[%a@]])@]@\n@\n\ + @[%a@]@]@\n\ + in@\n\ + Timer.stop Timer.init ;@\n\ + Statistics.report (Timer.create()) tmr (Timer.create()) ;@\n\ + Printf.printf \"RESULT: %%B\\n\" (None <> result)@\n\ + @\n\ + with exc ->@\n\ + print_endline (\"\\nRESULT: Internal Error: \"^\ + (Printexc.to_string exc)) ;@\n\ + flush_all () ;@\n\ + raise exc" + SH.fmt_caml minuend + (List.fmt ";@ " Var.fmt_caml) (Vars.to_list xs) + SH.fmt_caml subtrahend + ) + | "inconsistent" -> + TestGen.gen ("sat_" ^ (string_of_int id)) (fun ff -> + Format.fprintf ff + "let tmr = Timer.create() in Timer.start tmr ;@\n\ + try let result =@\n\ + @[Prover.inconsistent@\n\ + @[%a@]@]@\n\ + in@\n\ + Timer.stop Timer.init ;@\n\ + Statistics.report (Timer.create()) tmr (Timer.create()) ;@\n\ + Printf.printf \"RESULT: %%B\\n\" result@\n\ + @\n\ + with exc ->@\n\ + print_endline (\"\\nRESULT: Internal Error: \"^\ + (Printexc.to_string exc)) ;@\n\ + flush_all () ;@\n\ + raise exc" + SH.fmt_caml minuend + ) + | _ -> () diff --git a/src/UnitTests/TestGenProver.mli b/src/UnitTests/TestGenProver.mli new file mode 100644 index 0000000..10d62c2 --- /dev/null +++ b/src/UnitTests/TestGenProver.mli @@ -0,0 +1,9 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Utility code to generate stand-alone unit tests *) + +open Variable +open SymbolicHeap + + +val gen_query : int * string * (Vars.t * SH.t * Vars.t * SH.t) -> unit diff --git a/src/UnitTests/Variable_test.ml b/src/UnitTests/Variable_test.ml new file mode 100644 index 0000000..9b8cca8 --- /dev/null +++ b/src/UnitTests/Variable_test.ml @@ -0,0 +1,16 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +open Library + +open Variable + +let log = Log.std Variable.verbose +let printf x = Log.printf log x + + +let test () = + printf 0 "testing Variable" ; + + let old = Var.gensym "old" () in + let young = Var.gensym "young" () in + assert (Var.compare old young < 0) diff --git a/src/UnitTests/Variable_test.mli b/src/UnitTests/Variable_test.mli new file mode 100644 index 0000000..ad648b7 --- /dev/null +++ b/src/UnitTests/Variable_test.mli @@ -0,0 +1,3 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +val test : unit -> unit diff --git a/src/UnitTests/entailments.txt b/src/UnitTests/entailments.txt new file mode 100644 index 0000000..016ee53 --- /dev/null +++ b/src/UnitTests/entailments.txt @@ -0,0 +1,189 @@ +tt |/- emp +emp |/- 0!=0 +E!=F * tt |/- emp +emp |/- E y . x==y+z +emp |/- E x,y . x+y==y * x!=0 +a->{} |/- 0!=1 +emp |/- x==y +emp |/- E x,f . x.t.f==x.eps.f +emp |/- E x,f,g . x.t.f==x.g.f +emp |/- x==0 +x==x |/- x==0 +emp |/- 1+2==5 +emp |/- x+1==1 +emp |/- x!=1 +emp |/- x+2==1 +x->{} |/- x->{f:y} +x->{} |/- x->{f:y} * y!=0 +x->{} * y->{} |/- x->{h:H} * y->{h:H} +emp |/- E e0,f0,e1,f1 . dll(k;e0;f0;e1;f1) +e0!=e1 |/- E k,f0,f1 . dll(k;e0;f0;e1;f1) +emp |/- E k,f0,f1 . dll(k;e0;f0;e1;f1) +emp |/- E k,e0,e1 . dll(k;e0;f0;e1;f1) +emp |/- E k,e0,f0,e1,f1 . dll(k;e0;f0;e1;f1) * e0!=e1 + +e0->{B:f0,F:e1} |/- E f1 . dll(k;e0;f0;e1;f1) +e0->{B:f,F:e1} |/- E k,f1 . dll(k;e0;f0;e1;f1) +e1!=f1 * e0->{B:f0,F:e1} |/- E k . dll(k;e0;f0;e1;f1) + +dllh(h;k;e0;f0;e1;f1) = ls((\a,b,c,d. a==d * a->{B:b,F:c,H:h}); k;e0;f0;e1;f1) + +e0->{B:f0,F:e1} * e2->{B:f2,F:e3} |/- E k0,k1,h . dllh(h;k0;e0;f0;e1;e0) * dllh(h;k1;e2;f2;e3;e2) + +dll(k;e0;f0;e1;f1) * e1->{B:f1,F:e2} |/- E f2 . dll(k1;e0;f0;e2;f2) +dll(k;e0;f0;e1;f1) * e1->{B:f1,F:e2} |/- E k1 . dll(k1;e0;f0;e2;f2) +dll(k;e0;f0;e1;f1) * e1->{B:f1,F:e2} * f2!=e1 |/- E k1 . dll(k1;e0;f0;e2;f2) +dll(k;e0;f0;e1;f1) * e1->{B:f1,F:e2} |/- E k1 . f2!=e1 * dll(k1;e0;f0;e2;f2) +dll(k0;e0;f0;e0;f0) |/- E k1 . k0!=k1 * dll(k1;e0;f1;e0;f1) + +emp |- emp +e==e |- emp +emp |- E x,y . x!=y +emp |- E k . x==k+x * k==0 +emp |- E x . x!=0+1 +emp |- E x,y . x==0 * y==y+x +x+y==y |- x==0 +emp |- E x,y . x+y==y +tt \ emp = tt +e!=e |- ff +e!=f * e==f |- ff +e!=1 * e==1 |- ff +e!=e * tt |- emp +x!=0 |- 0!=x+1 +emp |- tt + +dll(k;x;y;z;0.) * x!=z |- ff +dll(k;x;y;z;w) * x!=z |- k!=0 * tt +dll(k;0.;y;0.;y) |- emp +e!=f |- e!=f +f!=e |- e!=f +e!=f |- f!=e +dll(k;e0;f0;e1;f1) |- dll(k;e0;f0;e1;f1) +e!=f * g!=f |- f!=e * tt +emp |- E x . x==x +e==g * g==f |- e==f +emp |- E x . x.f==x.eps.f +emp |- E x,t . x.f==x.eps.t = [f/t] +emp |- E x,t . x.t==x.eps.f = [f/t] +emp |- E x,t . x.t.f==x.g.f = [g/t] +emp |- E x,t . x.t.f==x.g.f = [g/t] +emp |- E x . x==0 +x->{} * y->{} * tt |- y->{} * tt +emp |- 0!=0+1 +x->{} |- x->{} +x->{F:f} |- x->{} +x->{F:f} * f->{} |- E z . x->{F:z} * z->{} +x->{F:f} * f!=h |- E g . x->{F:g} * g!=h +x->{} |- E y . y->{} +x->{} |- E y . y.->{} +dll(k;e0;f0;e2;f2) * k!=0 |- E k1,e1 . e0->{B:f0,F:e1} * dll(k1;e1;e0;e2;f2) +dll(1;e0;f0;e2;f2) |- E e1 . e0->{B:f0,F:e1} +dll(k;e0;f0;e2;f2) * k!=0 |- E k1,f1 . dll(k1;e0;f0;f2;f1) * f2->{B:f1,F:e2} +emp |- E e0,f0,e1,f1 . dll(0;e0;f0;e1;f1) +emp |- E k,e0,f0,e1,f1 . dll(k;e0;f0;e1;f1) +emp |- E k,f0,e1,f1 . dll(k;e0;f0;e1;f1) +emp |- E k,e0,f0,e1 . dll(k;e0;f0;e1;f1) +emp |- E k,e0,f0,e1,f1 . dll(k;e0;f0;e1;f1) * e0!=f1 +dll(0;w0;x0;y0;z0) |- E w1,x1,y1,z1 . dll(0;w1;x1;y1;z1) (cyclic) empty |- (cyclic) empty +e0->{B:f0,F:e1} |- E k,f1 . dll(k;e0;f0;e1;f1) +e0->{B:f,F:e1} |- E k,f0,f1 . dll(k;e0;f0;e1;f1) +k==1 * e0->{B:f0,F:e1} |- E f1 . dll(k;e0;f0;e1;f1) +e0->{B:f0,F:e1} * e1->{B:e0,F:e2} |- E k . dll(k;e0;f0;e2;e1) +f1->{B:f0,F:e1} |- E k,e0 . dll(k;e0;f0;e1;f1) +dll(k0;e0;f0;e1;f1) |- E k1 . dll(k1;e0;f0;e1;f1) +dll(k;e0;f0;e1;f1) * e1->{B:f1,F:e2} |- E k1,f2 . dll(k1;e0;f0;e2;f2) +dll(k;e0;f0;e1;f1) * e1->{B:f1,F:e2} * f2==e1 |- E k1 . dll(k1;e0;f0;e2;f2) +dll(k;e0;f0;e1;f1) * e1->{B:f1,F:e2} |- E k1 . dll(k1;e0;f0;e2;f2) * f2==e1 +dll(k;e0;f0;e1;f1) |- dll(k;e0;f0;e1;f1) +dll(k0;e0;f0;e1;f1) |- E k1 . dll(k1;e0;f0;e1;f1) * k0==k1 +dll(k;w0;x0;y0;z0) |- E w1,z1 . dll(k;w1;x0;y0;z1) +e0->{B:f0,F:e1} * dll(k0;e1;e0;e2;f2) |- E k1,e0' . dll(k1;e0';f0;e2;f2) +dll(k0;e0;f0;e0;f0) |- E e1 . dll(k0;e1;f0;e1;f0) + j.->{:g} * dll(_;_.;0.;f.;g) * f.->{B:g,F:e.} * dll(a;e.;f.;0.;_.) * a!=0 * g!=0. * h.->{:0.} * i.->{} +|- E n,o,p . j.->{:p} * dll(_;_.;0.;o.;p) * dll(n;o.;p;0.;_.) * n!=0 * p!=0. * h.->{:0.} * i.->{} + +dll'(k;e0;f0;e1;f1) = ls((\a,b,c,d. a==d * a->{B:c,F:b}); k;e0;f0;e1;f1) + +dll'(e+1;f.;g.;0.;h.) |- E l,m,n,o . dll'(l+1;m.;n.;0.;o.) +dll'(d+1;e.;f.;g.;h) * dll'(i+1;g.;h;j.;k.) |- E o . dll'(1+_;o.;h;j.;k.) * dll'(1+_;e.;f.;o.;h) + +sll(k;e0;e1) = ls((\a,b,c,d. a==d * a->{F:c}); k;e0;;e1;) + +sll(k;x;;y;) * x!=y |- E q . sll(_;x;;q;) * q->{F:y} + +dll(k;x;y;x;y) * k!=0 |- E z . dll(k;z;x;z;x) +y->{} * dll(k0;z;y;x;z) * dll(k1;z;x;y;z) |- x->{} * tt + +dll(1+_;e.;g.;g.;f.) |- E n,o . dll'(1+_;n.;g.;g.;o.) + +e0->{F:e1} |- sll(1;e0;e1) +e0->{F:e1} |- E k . sll(k;e0;e1) +e0->{F:e1} * e1->{F:e2} |- E k . sll(k;e0;e2) +e0->{F:e1} * sll(k;e1;e2) |- E k1 . sll(k1;e0;e2) +sll(k;e0;e1) * e1->{F:e2} |- E k1 . sll(k1;e0;e2) +sll(k0;e0;e1) * sll(k1;e1;e2) |- sll(k0+k1;e0;e2) +sll(k;e0;e1) * e1->{F:e2} |- E k1,x . e0->{F:x} * sll(k1;x;e2) +sll(k0;e0;e1) * e1->{F:e2} * sll(k1;e2;e0) |- sll(k0+k1+1,e1,e1) +k!=0 * sll(k,e0,e0) |- E k1,x . e0->{F:x} * sll(k1;x;e0) +y!=z * sll(k0;x;y) * sll(k1;x;z) |- x->{} * tt + + +emp |- emp +emp |/- x->{} +x->{} |/- emp +x->{} |- x->{} +x->{} |/- y->{} +x->{} |/- x->{F:y} +x->{F:y} |- x->{} +x->{F:y} |- x->{F:y} +x->{F:y} |/- x->{F:z} +x->{} * y->{} |- y->{} * x->{} + + +Note: the following are for the acyclic ls predicate: + +emp |- ls(x,x) +ls(x,x) |- emp + +x->{F:0} |- ls(x,0) +ls(x,0) |/- x->{F:0} +x->{F:y} |/- ls(x,y) +x!=y * x->{F:y} |- ls(x,y) + +x->{F:y} * y->{F:z} |- ls(x,y) * y->{F:z} +x->{F:y} * y->{F:0} |- ls(x,0) +x->{F:y} * y->{F:z} |/- ls(x,z) + +x->{F:y} * ls(y,0) |- ls(x,0) +x->{F:y} * ls(y,z) |/- ls(x,z) +x!=z * x->{F:y} * ls(y,z) |- ls(x,z) +x->{F:y} * ls(y,z) * z->{F:w} |- ls(x,z) * z->{F:w} +z!=w * x->{F:y} * ls(y,z) * ls(z,w) |- ls(x,z) * ls(z,w) + +ls(x,y) * y->{F:0} |- ls(x,0) +ls(x,y) * y->{F:z} |/- ls(x,z) +ls(x,y) * y->{F:z} * z->{F:w} |- ls(x,z) * z->{F:w} +z!=w * ls(x,y) * y->{F:z} * ls(z,w) |- ls(x,z) * ls(z,w) + +ls(x,y) * ls(y,0) |- ls(x,0) +ls(x,y) * ls(y,z) |/- ls(x,z) +ls(x,y) * ls(y,z) * z->{F:w} |- ls(x,z) * z->{F:w} +z!=w * ls(x,y) * ls(y,z) * ls(z,w) |- ls(x,z) * ls(z,w) + +y!=z * ls(x,y) * ls(x,z) * ls(y,0) * ls(z,0) |- false +y!=z * ls(x,y) * ls(x,z) * ls(y,w) * ls(z,w) |- (ls(x,z) * ls(z,x)) \/ (ls(x,y) * ls(y,x)) +y!=z * ls(x,y) * ls(x,z) * ls(y,u) * ls(z,v) |- (x==y==u * ls(x,z) * ls(z,v)) \/ (x==z==v * ls(x,y) * ls(y,u)) + +ls(x,z) * y->{F:z} * ls(z,0) |- y->{} * ls(x,0) + +x!=y * ls(x,y) |- E z'. x->{F:z'} * ls(z',y) +x!=0 * ls(x,y) |/- E z'. x->{F:z'} * ls(z',y) +x!=y * ls(x,y) |- E z'. ls(x,z') * z'->{F:y} +x!=y * ls(x,y) |- E w',z'. ls(x,w') * w'->{F:z'} * ls(z',y) + +ls(x,y) |- E z'. ls(x,z') * ls(z',y) +x!=y * ls(x,y) |- E w',z'. w'!=z' * ls(x,w') * ls(w',z') * ls(z',y) + +x->{F:y} * ls(y,x) |- E z'. ls(x,z') * z'->{F:x} + +y!=z * ls(x,y) * ls(x,z) * ls(y,w) * ls(z,w) |- E v'. ls(x,v') * ls(v',x) diff --git a/src/Variable.ml b/src/Variable.ml new file mode 100644 index 0000000..7551265 --- /dev/null +++ b/src/Variable.ml @@ -0,0 +1,148 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Variables *) + +open Library +open Type + +module L = (val Log.std Config.vVar : Log.LOG) + + +(*============================================================================ + Var + ============================================================================*) + +module Var = struct + + type sort = PointerSort | IntegerSort | BooleanSort | OffsetSort + + type t = { id: int; name: string; sort: sort } + + include UniqueId.Make(struct + type data = string * sort + type uniq = t + let get {id} = id + let set id (name, sort) = {id; name; sort} + end) + + let name v = v.name + let sort v = v.sort + + let gensym n s = gensym (n, s) + let gensyms vl = List.map (fun v -> gensym v.name v.sort) vl + let unsafe_create i n s = unsafe_create i (n, s) + + + module Vars = Set.Make(struct + type _t = t + type t = _t + let compare = compare + let equal = equal + end) + + + (** Formatting contexts. Members of [fst fxt] are existential and members of + [snd fxt] additionally occur at most once. *) + type fxt = Vars.t * Vars.t + + (** Verbosity levels: + 0. display abbreviated names, quantifier strength + 1. add integer identities except of uniquely-occurring existentials + 2. do not abbreviate program specific names + 3. do not abbreviate frontend-introduced names + 4. add integer identities of uniquely-occurring existentials + 5. display sorts + *) + let fmt_sort ff = function + | PointerSort -> Format.pp_print_string ff "P" + | IntegerSort -> Format.pp_print_string ff "I" + | BooleanSort -> Format.pp_print_string ff "B" + | OffsetSort -> Format.pp_print_string ff "O" + + let fmtp fxt ff v = + let is_existl v = Vars.mem v (fst fxt) in + let is_unique v = Vars.mem v (snd fxt) in + let fmt_name ff v = + if !Config.vVar >= (if is_unique v then 5 else 0) then + Format.pp_print_string ff (Hooks.var_name v.name) + in + let fmt_strength ff v = + if is_existl v then + Format.pp_print_string ff "?" + else if !Config.vVar >= 1 then + Format.pp_print_string ff "!" + in + let fmt_id ff v = + if !Config.vVar >= (if is_unique v then 4 else 1) then + Format.pp_print_int ff v.id + in + let fmt_sort ff v = + if !Config.vVar >= 5 then + fmt_sort ff v.sort + in + Format.fprintf ff "%a%a%a%a" fmt_name v fmt_strength v fmt_id v fmt_sort v + + let fmt ff = fmtp (Vars.empty,Vars.empty) ff + + let fmt_caml_sort ff x = + Format.pp_print_string ff + (match x with + | PointerSort -> "Var.PointerSort" + | IntegerSort -> "Var.IntegerSort" + | BooleanSort -> "Var.BooleanSort" + | OffsetSort -> "Var.OffsetSort") + + let fmt_caml ff {id; name; sort} = + Format.fprintf ff "(Var.unsafe_create %i \"%s\" %a)" + id name fmt_caml_sort sort + + let sort_of_type ty = + match Typ.desc ty with + | Typ.Bool -> BooleanSort + | Typ.Int _ + | Typ.Float _ -> IntegerSort + | Typ.Pointer _ + | Typ.Function _ + | Typ.Top + | Typ.Array _ -> PointerSort + | Typ.Named _ + | Typ.Structure _ + | Typ.Union _ + | Typ.Enum _ -> + Config.vTyp := max !Config.vTyp 2 ; + failwithf "sort_of_type: unexpected type: %a" Typ.fmt ty + +end + + + +(*============================================================================ + Collections + ============================================================================*) + +module Vars = struct + include Var.Vars + + let gensyms s = map (fun v -> Var.gensym (Var.name v) (Var.sort v)) s + + let fmtp_embrace prefix suffix fxt ff s = + match to_list s with + | [] -> () + | vl -> + Format.fprintf ff "%( fmt %)%a%( fmt %)" + prefix (List.fmt ",@ " (Var.fmtp fxt)) vl suffix + + let fmt_embrace prefix suffix ff = fmtp_embrace prefix suffix (empty,empty) ff + + let fmtp fxt ff = fmtp_embrace "" "" fxt ff + + let fmt ff = fmtp (empty,empty) ff + + let fmt_caml ff vs = + Format.fprintf ff "(Vars.of_list [@,@[%a@]])" + (List.fmt ";@ " Var.fmt_caml) (to_list vs) + +end + + +module VarMap = Map.Make(Var) diff --git a/src/Variable.mli b/src/Variable.mli new file mode 100644 index 0000000..044ad63 --- /dev/null +++ b/src/Variable.mli @@ -0,0 +1,75 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Variables *) + +open Library + +open Type + + +(*============================================================================ + Var + ============================================================================*) + +(** Logical Variables *) +module rec Var : sig + type sort = PointerSort | IntegerSort | BooleanSort | OffsetSort + + type t + + val id : t -> int + val name : t -> string + val sort : t -> sort + + (** [gensym s a] returns a fresh variable whose name is based on [s], + and is of type [a]. *) + val gensym : string -> sort -> t + val gensyms : t list -> t list + + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + + (** Formatting contexts. Members of [fst fxt] are existential and members of + [snd fxt] additionally occur at most once. *) + type fxt = Vars.t * Vars.t + + val fmtp : fxt -> t formatter + val fmt : t formatter + val fmt_sort : sort formatter + val fmt_caml : t formatter + + val marshal : out_channel -> unit + val unmarshal : in_channel -> unit + + val unsafe_create : int -> string -> sort -> t + + val sort_of_type : Typ.t -> sort +end + + + +(*============================================================================ + Collections + ============================================================================*) + +(** Sets of variables *) +and Vars : sig + include Set.S with type elt = Var.t + + val gensyms : t -> t + + val fmtp_embrace : + (unit,Format.formatter,unit)format -> (unit,Format.formatter,unit)format -> Var.fxt -> t formatter + + val fmt_embrace : + (unit,Format.formatter,unit)format -> (unit,Format.formatter,unit)format -> + t formatter + + val fmtp : Var.fxt -> t formatter + val fmt : t formatter + val fmt_caml : t formatter +end + + +module VarMap : (Map.S with type key = Var.t) diff --git a/src/_tags b/src/_tags new file mode 100644 index 0000000..ce53320 --- /dev/null +++ b/src/_tags @@ -0,0 +1 @@ +<**/contaminated*/*.ml>: warn_z diff --git a/src/contaminated/PolySet.ml b/src/contaminated/PolySet.ml new file mode 100644 index 0000000..85fd128 --- /dev/null +++ b/src/contaminated/PolySet.ml @@ -0,0 +1,330 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: set.ml,v 1.19 2004/11/25 00:04:15 doligez Exp $ *) + +(* Sets over ordered types *) + +module type OrderedType = + sig + type 'k t + val compare: 'k t -> 'k t -> int + end + +module type S = + sig + type 'k elt + type 'k t + val empty: 'k t + val is_empty: 'k t -> bool + val mem: 'k elt -> 'k t -> bool + val add: 'k elt -> 'k t -> 'k t + val singleton: 'k elt -> 'k t + val remove: 'k elt -> 'k t -> 'k t + val union: 'k t -> 'k t -> 'k t + val inter: 'k t -> 'k t -> 'k t + val diff: 'k t -> 'k t -> 'k t + val compare: 'k t -> 'k t -> int + val equal: 'k t -> 'k t -> bool + val subset: 'k t -> 'k t -> bool + val iter: ('k elt -> unit) -> 'k t -> unit + val fold: ('k elt -> 'a -> 'a) -> 'k t -> 'a -> 'a + val for_all: ('k elt -> bool) -> 'k t -> bool + val exists: ('k elt -> bool) -> 'k t -> bool + val filter: ('k elt -> bool) -> 'k t -> 'k t + val partition: ('k elt -> bool) -> 'k t -> 'k t * 'k t + val cardinal: 'k t -> int + val elements: 'k t -> 'k elt list + val min_elt: 'k t -> 'k elt + val max_elt: 'k t -> 'k elt + val choose: 'k t -> 'k elt + val split: 'k elt -> 'k t -> 'k t * bool * 'k t + end + +module Make(Ord: OrderedType) = + struct + type 'k elt = 'k Ord.t + type 'k t = Empty | Node of 'k t * 'k elt * 'k t * int + + (* Sets are represented by balanced binary trees (the heights of the + children differ by at most 2 *) + + let height = function + Empty -> 0 + | Node(_, _, _, h) -> h + + (* Creates a new node with left son l, value v and right son r. + We must have all elements of l < v < all elements of r. + l and r must be balanced and | height l - height r | <= 2. + Inline expansion of height for better speed. *) + + let create l v r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + + (* Same as create, but performs one step of rebalancing if necessary. + Assumes l and r balanced and | height l - height r | <= 3. + Inline expansion of create for better speed in the most frequent case + where no rebalancing is required. *) + + let bal l v r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Set.bal" + | Node(ll, lv, lr, _) -> + if height ll >= height lr then + create ll lv (create lr v r) + else begin + match lr with + Empty -> invalid_arg "Set.bal" + | Node(lrl, lrv, lrr, _)-> + create (create ll lv lrl) lrv (create lrr v r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Set.bal" + | Node(rl, rv, rr, _) -> + if height rr >= height rl then + create (create l v rl) rv rr + else begin + match rl with + Empty -> invalid_arg "Set.bal" + | Node(rll, rlv, rlr, _) -> + create (create l v rll) rlv (create rlr rv rr) + end + end else + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + + (* Insertion of one element *) + + let rec add x = function + Empty -> Node(Empty, x, Empty, 1) + | Node(l, v, r, _) as t -> + let c = Ord.compare x v in + if c = 0 then t else + if c < 0 then bal (add x l) v r else bal l v (add x r) + + (* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + + let rec join l v r = + match (l, r) with + (Empty, _) -> add v r + | (_, Empty) -> add v l + | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> + if lh > rh + 2 then bal ll lv (join lr v r) else + if rh > lh + 2 then bal (join l v rl) rv rr else + create l v r + + (* Smallest and greatest element of a set *) + + let rec min_elt = function + Empty -> raise Not_found + | Node(Empty, v, r, _) -> v + | Node(l, v, r, _) -> min_elt l + + let rec max_elt = function + Empty -> raise Not_found + | Node(l, v, Empty, _) -> v + | Node(l, v, r, _) -> max_elt r + + (* Remove the smallest element of the given set *) + + let rec remove_min_elt = function + Empty -> invalid_arg "Set.remove_min_elt" + | Node(Empty, v, r, _) -> r + | Node(l, v, r, _) -> bal (remove_min_elt l) v r + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + Assume | height l - height r | <= 2. *) + + let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + + let concat t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) + + (* Splitting. split x s returns a triple (l, present, r) where + - l is the set of elements of s that are < x + - r is the set of elements of s that are > x + - present is false if s contains no element equal to x, + or true if s contains an element equal to x. *) + + let rec split x = function + Empty -> + (Empty, false, Empty) + | Node(l, v, r, _) -> + let c = Ord.compare x v in + if c = 0 then (l, true, r) + else if c < 0 then + let (ll, pres, rl) = split x l in (ll, pres, join rl v r) + else + let (lr, pres, rr) = split x r in (join l v lr, pres, rr) + + (* Implementation of the set operations *) + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let rec mem x = function + Empty -> false + | Node(l, v, r, _) -> + let c = Ord.compare x v in + c = 0 || mem x (if c < 0 then l else r) + + let singleton x = Node(Empty, x, Empty, 1) + + let rec remove x = function + Empty -> Empty + | Node(l, v, r, _) -> + let c = Ord.compare x v in + if c = 0 then merge l r else + if c < 0 then bal (remove x l) v r else bal l v (remove x r) + + let rec union s1 s2 = + match (s1, s2) with + (Empty, t2) -> t2 + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> + if h1 >= h2 then + if h2 = 1 then add v2 s1 else begin + let (l2, _, r2) = split v1 s2 in + join (union l1 l2) v1 (union r1 r2) + end + else + if h1 = 1 then add v1 s2 else begin + let (l1, _, r1) = split v2 s1 in + join (union l1 l2) v2 (union r1 r2) + end + + let rec inter s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> Empty + | (Node(l1, v1, r1, _), t2) -> + match split v1 t2 with + (l2, false, r2) -> + concat (inter l1 l2) (inter r1 r2) + | (l2, true, r2) -> + join (inter l1 l2) v1 (inter r1 r2) + + let rec diff s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, _), t2) -> + match split v1 t2 with + (l2, false, r2) -> + join (diff l1 l2) v1 (diff r1 r2) + | (l2, true, r2) -> + concat (diff l1 l2) (diff r1 r2) + + type 'k enumeration = End | More of 'k elt * 'k t * 'k enumeration + + let rec cons_enum s e = + match s with + Empty -> e + | Node(l, v, r, _) -> cons_enum l (More(v, r, e)) + + let rec compare_aux e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, r1, e1), More(v2, r2, e2)) -> + let c = Ord.compare v1 v2 in + if c <> 0 + then c + else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) + + let compare s1 s2 = + compare_aux (cons_enum s1 End) (cons_enum s2 End) + + let equal s1 s2 = + compare s1 s2 = 0 + + let rec subset s1 s2 = + match (s1, s2) with + Empty, _ -> + true + | _, Empty -> + false + | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> + let c = Ord.compare v1 v2 in + if c = 0 then + subset l1 l2 && subset r1 r2 + else if c < 0 then + subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 + else + subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 + + let rec iter f = function + Empty -> () + | Node(l, v, r, _) -> iter f l; f v; iter f r + + let rec fold f s accu = + match s with + Empty -> accu + | Node(l, v, r, _) -> fold f r (f v (fold f l accu)) + + let rec for_all p = function + Empty -> true + | Node(l, v, r, _) -> p v && for_all p l && for_all p r + + let rec exists p = function + Empty -> false + | Node(l, v, r, _) -> p v || exists p l || exists p r + + let filter p s = + let rec filt accu = function + | Empty -> accu + | Node(l, v, r, _) -> + filt (filt (if p v then add v accu else accu) l) r in + filt Empty s + + let partition p s = + let rec part (t, f as accu) = function + | Empty -> accu + | Node(l, v, r, _) -> + part (part (if p v then (add v t, f) else (t, add v f)) l) r in + part (Empty, Empty) s + + let rec cardinal = function + Empty -> 0 + | Node(l, v, r, _) -> cardinal l + 1 + cardinal r + + let rec elements_aux accu = function + Empty -> accu + | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l + + let elements s = + elements_aux [] s + + let choose = min_elt + + end diff --git a/src/contaminated/PolySet.mli b/src/contaminated/PolySet.mli new file mode 100644 index 0000000..28a97b1 --- /dev/null +++ b/src/contaminated/PolySet.mli @@ -0,0 +1,153 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: set.mli,v 1.33 2005/07/21 14:52:45 doligez Exp $ *) + +(** Sets over ordered types. + + This module implements the set data structure, given a total ordering + function over the set elements. All operations over sets + are purely applicative (no side-effects). + The implementation uses balanced binary trees, and is therefore + reasonably efficient: insertion and membership take time + logarithmic in the size of the set, for instance. +*) + +module type OrderedType = + sig + type 'k t + (** The type of the set elements. *) + val compare : 'k t -> 'k t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that + [f e1 e2] is zero if the elements [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) + end +(** Input signature of the functor {!PolySet.Make}. *) + +module type S = + sig + type 'k elt + (** The type of the set elements. *) + + type 'k t + (** The type of sets. *) + + val empty: 'k t + (** The empty set. *) + + val is_empty: 'k t -> bool + (** Test whether a set is empty or not. *) + + val mem: 'k elt -> 'k t -> bool + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + val add: 'k elt -> 'k t -> 'k t + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + + val singleton: 'k elt -> 'k t + (** [singleton x] returns the one-element set containing only [x]. *) + + val remove: 'k elt -> 'k t -> 'k t + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged. *) + + val union: 'k t -> 'k t -> 'k t + (** Set union. *) + + val inter: 'k t -> 'k t -> 'k t + (** Set intersection. *) + + (** Set difference. *) + val diff: 'k t -> 'k t -> 'k t + + val compare: 'k t -> 'k t -> int + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + val equal: 'k t -> 'k t -> bool + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + val subset: 'k t -> 'k t -> bool + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + val iter: ('k elt -> unit) -> 'k t -> unit + (** [iter f s] applies [f] in turn to all elements of [s]. + The elements of [s] are presented to [f] in increasing order + with respect to the ordering over the type of the elements. *) + + val fold: ('k elt -> 'a -> 'a) -> 'k t -> 'a -> 'a + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s], in increasing order. *) + + val for_all: ('k elt -> bool) -> 'k t -> bool + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + val exists: ('k elt -> bool) -> 'k t -> bool + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + val filter: ('k elt -> bool) -> 'k t -> 'k t + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + val partition: ('k elt -> bool) -> 'k t -> 'k t * 'k t + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + val cardinal: 'k t -> int + (** Return the number of elements of a set. *) + + val elements: 'k t -> 'k elt list + (** Return the list of all elements of the given set. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!PolySet.Make}. *) + + val min_elt: 'k t -> 'k elt + (** Return the smallest element of the given set + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the set is empty. *) + + val max_elt: 'k t -> 'k elt + (** Same as {!PolySet.S.min_elt}, but returns the largest element of the + given set. *) + + val choose: 'k t -> 'k elt + (** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified, + but equal elements will be chosen for equal sets. *) + + val split: 'k elt -> 'k t -> 'k t * bool * 'k t + (** [split x s] returns a triple [(l, present, r)], where + [l] is the set of elements of [s] that are + strictly less than [x]; + [r] is the set of elements of [s] that are + strictly greater than [x]; + [present] is [false] if [s] contains no element equal to [x], + or [true] if [s] contains an element equal to [x]. *) + end +(** Output signature of the functor {!PolySet.Make}. *) + +module Make (Ord : OrderedType) : S with type 'k elt = 'k Ord.t +(** Functor building an implementation of the set structure + given a totally ordered type. *) diff --git a/src/doc/depend_module.mli b/src/doc/depend_module.mli new file mode 100644 index 0000000..d5a6b47 --- /dev/null +++ b/src/doc/depend_module.mli @@ -0,0 +1,2 @@ +(** Module dependency graph. + @see Module dependency graph. *) diff --git a/src/frontend_esp.ml b/src/frontend_esp.ml new file mode 100644 index 0000000..cd7a6ae --- /dev/null +++ b/src/frontend_esp.ml @@ -0,0 +1,2618 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** ESP -> SLAyer translator **) + +open Library + +open Type +open Variable +open Expression +open Program +module I = Inst +module C = Cmnd +module K = ControlPoint + +(*============================================================================ + Tracing + ============================================================================*) + +(* lvl are: 2=func, 4=stmt, 8=expr. *) +module L = (val Log.std Config.vFE : Log.LOG) + +(*============================================================================ + Wrap up Expr functions. + ============================================================================*) +module Exp_ = Exp +module E : (module type of Exp_) = struct + + include Exp + + (* Conversions *) + + let conv_to_ptr_sort e = + match Exp.convert Var.PointerSort e with + | Some(e) -> e + | None -> failwithf "conversion to PointerSort failed: %a" Exp.fmt e + + let conv_to_int_sort e = + match Exp.convert Var.IntegerSort e with + | Some(e) -> e + | None -> failwithf "conversion to IntegerSort failed: %a" Exp.fmt e + + let conv_to_bool_sort e = + match Exp.convert Var.BooleanSort e with + | Some(e) -> e + | None -> failwithf "conversion to BooleanSort failed: %a" Exp.fmt e + + + (* Convert arguments to required sort *) + + let mkAdd t f = Exp.mkAdd (conv_to_ptr_sort t) f + + let mkSub t f = Exp.mkSub (conv_to_ptr_sort t) f + + let mkAdds t ff = Exp.mkAdds (conv_to_ptr_sort t) ff + + let mkSubs t ff = Exp.mkSubs (conv_to_ptr_sort t) ff + + let mkIdx e0 e1 = Exp.mkIdx (conv_to_ptr_sort e0) (conv_to_int_sort e1) + + let mkZMin e0 = Exp.mkZMin (conv_to_int_sort e0) + + let mkZDiv e0 e1 = Exp.mkZDiv (conv_to_int_sort e0) (conv_to_int_sort e1) + + let mkZRem e0 e1 = Exp.mkZRem (conv_to_int_sort e0) (conv_to_int_sort e1) + + let mkZMod e0 e1 = Exp.mkZMod (conv_to_int_sort e0) (conv_to_int_sort e1) + + let mkZAdd ee = Exp.mkZAdd (Array.map conv_to_int_sort ee) + + let mkZSub ee = Exp.mkZSub (Array.map conv_to_int_sort ee) + + let mkZMul ee = Exp.mkZMul (Array.map conv_to_int_sort ee) + + let mkUFun op ee = Exp.mkUFun op (Array.map conv_to_int_sort ee) + + let mkNot e0 = Exp.mkNot (conv_to_bool_sort e0) + + let mkAnd ee = Exp.mkAnd (Array.map conv_to_bool_sort ee) + + let mkOr ee = Exp.mkOr (Array.map conv_to_bool_sort ee) + + let mkImp e0 e1 = Exp.mkImp (conv_to_bool_sort e0) (conv_to_bool_sort e1) + + let mkIff e0 e1 = Exp.mkIff (conv_to_bool_sort e0) (conv_to_bool_sort e1) + + let mkXor e0 e1 = Exp.mkXor (conv_to_bool_sort e0) (conv_to_bool_sort e1) + + let mkZLt e0 e1 = Exp.mkZLt (conv_to_int_sort e0) (conv_to_int_sort e1) + + let mkZLe e0 e1 = Exp.mkZLe (conv_to_int_sort e0) (conv_to_int_sort e1) + + let mkZGt e0 e1 = Exp.mkZGt (conv_to_int_sort e0) (conv_to_int_sort e1) + + let mkZGe e0 e1 = Exp.mkZGe (conv_to_int_sort e0) (conv_to_int_sort e1) + + + (* Debug printing *) + + let mkAdd t f = + try mkAdd t f with e -> (L.printf 0 "mkAdd %a %a failed" fmt t Fld.fmt f ; raise(e)) + + let mkSub t f = + try mkSub t f with e -> (L.printf 0 "mkSub %a %a failed" fmt t Fld.fmt f ; raise(e)) + + let mkAdds t ff = + try mkAdds t ff with e -> (L.printf 0 "mkAdds %a %a failed" fmt t (List.fmt "+" Fld.fmt) ff ; raise(e)) + + let mkSubs t ff = + try mkSubs t ff with e -> (L.printf 0 "mkSubs %a %a failed" fmt t (List.fmt "+" Fld.fmt) ff ; raise(e)) + + let mkIdx e0 e1 = + try mkIdx e0 e1 with e -> (L.printf 0 "mkIdx %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkZMin e0 = + try mkZMin e0 with e -> (L.printf 0 "mkZMin %a failed" fmt e0 ; raise(e)) + + let mkZDiv e0 e1 = + try mkZDiv e0 e1 with e -> (L.printf 0 "mkZDiv %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkZRem e0 e1 = + try mkZRem e0 e1 with e -> (L.printf 0 "mkZRem %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkZMod e0 e1 = + try mkZMod e0 e1 with e -> (L.printf 0 "mkZMod %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkZAdd ee = + try mkZAdd ee with e -> (L.printf 0 "mkZAdd %a failed" (Array.fmt "," fmt) ee ; raise(e)) + + let mkZSub ee = + try mkZSub ee with e -> (L.printf 0 "mkZSub %a failed" (Array.fmt "," fmt) ee ; raise(e)) + + let mkZMul ee = + try mkZMul ee with e -> (L.printf 0 "mkZMul %a failed" (Array.fmt "," fmt) ee ; raise(e)) + + let mkUFun op ee = + try mkUFun op ee with e -> (L.printf 0 "mkZUFun %a failed" (Array.fmt "," fmt) ee ; raise(e)) + + let mkNot e0 = + try mkNot e0 with e -> (L.printf 0 "mkNot %a failed" fmt e0 ; raise(e)) + + let mkAnd ee = + try mkAnd ee with e -> (L.printf 0 "mkAnd %a failed" (Array.fmt "," fmt) ee ; raise(e)) + + let mkOr ee = + try mkOr ee with e -> (L.printf 0 "mkOr %a failed" (Array.fmt "," fmt) ee ; raise(e)) + + let mkImp e0 e1 = + try mkImp e0 e1 with e -> (L.printf 0 "mkImp %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkIff e0 e1 = + try mkIff e0 e1 with e -> (L.printf 0 "mkIff %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkXor e0 e1 = + try mkXor e0 e1 with e -> (L.printf 0 "mkXor %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkEq e0 e1 = + try mkEq e0 e1 with e -> (L.printf 0 "mkEq %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkDq e0 e1 = + try mkDq e0 e1 with e -> (L.printf 0 "mkDq %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkDistinct ee = + try mkDistinct ee with e -> (L.printf 0 "mkDistinct %a failed" (Array.fmt "," fmt) ee ; raise(e)) + + let mkZLt e0 e1 = + try mkZLt e0 e1 with e -> (L.printf 0 "mkZLt %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkZLe e0 e1 = + try mkZLe e0 e1 with e -> (L.printf 0 "mkZLe %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkZGt e0 e1 = + try mkZGt e0 e1 with e -> (L.printf 0 "mkZGt %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkZGe e0 e1 = + try mkZGe e0 e1 with e -> (L.printf 0 "mkZGe %a %a failed" fmt e0 fmt e1 ; raise(e)) + + let mkIte e0 e1 e2 = + try mkIte e0 e1 e2 with e -> (L.printf 0 "mkIte %a %a %a failed" fmt e0 fmt e1 fmt e2 ; raise(e)) + +end + +(*============================================================================ + ESP data structure functions. + ============================================================================*) + +module SESPExt = struct + +let rec fold_expr fn_symb fn_expr expr z = + let open SESP in + let z = fn_expr expr z in + match Expr.refine expr with + | ExprLEAF(SYMBOL(s)) -> + fn_symb s z + | ExprUNARY(_, e) -> + fold_expr fn_symb fn_expr e z + | ExprASSIGN(_,(e,f)) + | ExprINCREMENT(_,(e,f)) + | ExprCOMPARE(_,(e,f)) + | ExprBINARY(_,(e,f)) -> + fold_expr fn_symb fn_expr e (fold_expr fn_symb fn_expr f z) + | ExprTERNARY(_,(e,f,g)) -> + fold_expr fn_symb fn_expr e (fold_expr fn_symb fn_expr f (fold_expr fn_symb fn_expr g z)) + | ExprNARY(_,es) -> + Array.fold_right (fold_expr fn_symb fn_expr) es z + | _ -> + z + +let fold_node fn_symb fn_expr fn_node node z = + let open SESP in + let z = fn_node node z in + match Node.refine node with + | Decl(s,_,_) + | StaticDeclBegin(s,_,_) -> + fn_symb s z + | CallReturn(Some(e),_) + | Branch(e,_,_) + | Expression(Some(e),_) + | Return(e,_) -> + fold_expr fn_symb fn_expr e z + | Call( (Direct(symb) | DirectMethod(symb) | Virtual(symb) | Intrinsic(symb)), es,_,_,_,_) -> + fn_symb symb (Array.fold_right (fold_expr fn_symb fn_expr) es z) + | Call( (Indirect(e) | IndirectMethod(e)), es,_,_,_,_) -> + fold_expr fn_symb fn_expr e (Array.fold_right (fold_expr fn_symb fn_expr) es z) + | Switch(e, ens,_) -> + Array.fold_right (fun (e,_) z -> fold_expr fn_symb fn_expr e z) ens (fold_expr fn_symb fn_expr e z) + | _ -> + z + +let fold_cfg fn_symb fn_expr fn_node cfg z = + let open SESP in + let formals,_ = Cfg.formals cfg in + let freturn = Cfg.formal_return cfg in + z |> + Array.fold_right fn_symb formals |> + Option.fold fn_symb freturn |> + Array.fold_right (fold_node fn_symb fn_expr fn_node) (Cfg.nodes cfg) + + +(* Types *) +let rec get_type ty = + let open SESP in + let open Type in + match refine ty with + | TypeAlias(_,ty) | TypeModifier(_,ty) -> get_type ty + | ety -> ety + +(* SI: why is this MM? In fe_slam too. *) +module CfgHMMap = HashMultiMap.Make(struct + type t = SESP.symb + let equal = Pervasives.( = ) + let hash = Hashtbl.hash +end) + +module CfgNodeHMap = HashMap.Make(struct + type t = SESP.symb * SESP.id + let equal = Pervasives.( = ) + let hash = Hashtbl.hash +end) + +module CfgSymbHMap = HashMap.Make(struct + type t = SESP.symb * SESP.symb + let equal = Pervasives.( = ) + let hash = Hashtbl.hash +end) + +module SymbHMap = HashMap.Make(struct + type t = SESP.symb + let equal = Pervasives.( = ) + let hash = Hashtbl.hash +end) + + +(* fmt *) + +let fmt_assign_op ff = function + | SESP.ASSIGN -> Format.fprintf ff "=" + | SESP.ASSIGNPLUS -> Format.fprintf ff "+=" + | SESP.ASSIGNMINUS -> Format.fprintf ff "-=" + | SESP.ASSIGNMULT -> Format.fprintf ff "*=" + | SESP.ASSIGNDIV -> Format.fprintf ff "/=" + | SESP.ASSIGNREM -> Format.fprintf ff "%%=" + | SESP.ASSIGNAND -> Format.fprintf ff "&=" + | SESP.ASSIGNOR -> Format.fprintf ff "|=" + | SESP.ASSIGNXOR -> Format.fprintf ff "^=" + | SESP.ASSIGNLSHIFT -> Format.fprintf ff "<<=" + | SESP.ASSIGNRSHIFT -> Format.fprintf ff ">>=" + | SESP.ASSIGNRSHIFTU -> Format.fprintf ff ">>=" + | SESP.DOTSTAR -> Format.fprintf ff ".*" + | SESP.ARROWSTAR -> Format.fprintf ff "->*" + +let assign_op_conv op = + (match op with + | SESP.ASSIGN -> None + | SESP.ASSIGNPLUS -> Some (SESP.PLUS) + | SESP.ASSIGNMINUS -> Some (SESP.MINUS) + | SESP.ASSIGNMULT -> Some (SESP.MULT) + | SESP.ASSIGNDIV -> Some (SESP.DIV) + | SESP.ASSIGNREM -> Some (SESP.REM) + | SESP.ASSIGNAND -> Some (SESP.BITAND) + | SESP.ASSIGNOR -> Some (SESP.BITOR) + | SESP.ASSIGNXOR -> Some (SESP.XOR) + | SESP.ASSIGNLSHIFT -> Some (SESP.LSHIFT) + | SESP.ASSIGNRSHIFT -> Some (SESP.RSHIFT) + | SESP.ASSIGNRSHIFTU -> Some (SESP.RSHIFTU) + | SESP.DOTSTAR + | SESP.ARROWSTAR -> failwith "I dont know what this does") + +let fmt_increment_op ff = function + | SESP.PREINCR | SESP.POSTINCR -> + Format.fprintf ff "++" + | SESP.PREDECR | SESP.POSTDECR -> + Format.fprintf ff "--" + +let fmt_binary_op ff = function + | SESP.BITAND -> Format.fprintf ff "&" + | SESP.BITOR -> Format.fprintf ff "|" + | SESP.XOR -> Format.fprintf ff "^" + | SESP.DIV -> Format.fprintf ff "\\" + | SESP.LSHIFT -> Format.fprintf ff "<<" + | SESP.MINUS -> Format.fprintf ff "-" + | SESP.MULT -> Format.fprintf ff "*" + | SESP.PLUS -> Format.fprintf ff "+" + | SESP.REM -> Format.fprintf ff "%%" + | SESP.RSHIFT -> Format.fprintf ff ">>" + | SESP.INDEX -> Format.fprintf ff "[]" + | SESP.PLUS_OVF -> Format.fprintf ff "+o" + | SESP.MINUS_OVF -> Format.fprintf ff "-o" + | SESP.MULT_OVF -> Format.fprintf ff "*o" + | SESP.RSHIFTU -> Format.fprintf ff ">>u" + | SESP.BINARY -> Format.fprintf ff "binop" + +let fmt_compare_op ff = function + | SESP.EQUALS -> Format.fprintf ff "==" + | SESP.GE -> Format.fprintf ff ">=" + | SESP.GT -> Format.fprintf ff ">" + | SESP.LE -> Format.fprintf ff "<=" + | SESP.LEU -> Format.fprintf ff "<=u" + | SESP.LT -> Format.fprintf ff "<" + | SESP.LTU -> Format.fprintf ff " Format.fprintf ff "!=" + +let fmt_symb ff symb = + let symb_str = SESP.Symb.undecoratedname symb in + Format.fprintf ff "%s" symb_str + +let rec fmt_expr ff pe = + fmt_expr_ ff pe +(* Format.fprintf ff "%a : %s" fmt_expr_ pe (SESP.Type.to_string (SESP.Expr.ctype pe)) *) + +and fmt_expr_ ff pe = + match SESP.Expr.refine pe with + | SESP.ExprLEAF leaf -> ( + match leaf with + | SESP.NOP -> Format.fprintf ff "NOP" + | SESP.CONSTANT i -> Format.fprintf ff "(%Ld)" i + | SESP.FLOAT f -> Format.fprintf ff "(%f)" f + | SESP.STRING(_, str, _)-> Format.fprintf ff "(\"%s\")" str + | SESP.FIELD -> + let symb = SESP.Expr.field pe in + let symb_str = + match symb with + | Some s -> SESP.Symb.name s + | None -> failwith "fmt_expr:FIELD" + in + Format.fprintf ff "(\"%s\")" symb_str + | SESP.SYMBOL symb -> + Format.fprintf ff "(%a)" fmt_symb symb + | SESP.CURRENTEXCEPTION -> + Format.fprintf ff "current_exn" + | SESP.NEWOBJ -> + Format.fprintf ff "new_obj" + | SESP.TYPEID_TYPE -> + Format.fprintf ff "typeid_ty") + | SESP.ExprUNARY(SESP.DOT,e1) -> + let fldo = SESP.Expr.field pe in + (match fldo with + | Some fld -> Format.fprintf ff "(%a . %a)" fmt_expr e1 fmt_symb fld + | None -> failwith "ExprUnary(DOT,_) has no fld") + | SESP.ExprUNARY(SESP.ARROW,e1) -> + let fldo = SESP.Expr.field pe in + (match fldo with + | Some fld -> Format.fprintf ff "(%a -> %a)" fmt_expr e1 fmt_symb fld + | None -> failwith "ExprUnary(ARROW,_) has no fld") + | SESP.ExprUNARY(SESP.NEGATE, e1) -> Format.fprintf ff "(- %a)" fmt_expr e1 + | SESP.ExprUNARY(SESP.NOT, e1) -> Format.fprintf ff "(! %a)" fmt_expr e1 + | SESP.ExprUNARY(SESP.BITNOT, e1) -> Format.fprintf ff "(~ %a)" fmt_expr e1 + | SESP.ExprUNARY(SESP.UPLUS, e1) -> Format.fprintf ff "(+ %a)" fmt_expr e1 + | SESP.ExprUNARY(SESP.ADDRESS, e1) -> Format.fprintf ff "(& %a)" fmt_expr e1 + | SESP.ExprUNARY(SESP.DEREF, e1) -> Format.fprintf ff "(* %a)" fmt_expr e1 + | SESP.ExprUNARY(_, e1) -> Format.fprintf ff "(%s %a)" (SESP.Expr.kind_as_string pe) fmt_expr e1 + | SESP.ExprASSIGN(op,(e1,e2)) -> + Format.fprintf ff "(%a %a %a)" + fmt_expr e1 fmt_assign_op op fmt_expr e2 + | SESP.ExprINCREMENT(op,(e1,_e2)) -> ( + match op with + | SESP.PREINCR | SESP.PREDECR -> + Format.fprintf ff "(%a %a)" + fmt_increment_op op fmt_expr e1 + | SESP.POSTINCR | SESP.POSTDECR -> + Format.fprintf ff "(%a %a)" + fmt_expr e1 fmt_increment_op op) + | SESP.ExprCOMPARE(op,(e1,e2)) -> + Format.fprintf ff "(%a %a %a)" + fmt_expr e1 fmt_compare_op op fmt_expr e2 + | SESP.ExprBINARY(op,(e1,e2)) -> + Format.fprintf ff "(%a %a %a)" + fmt_expr e1 fmt_binary_op op fmt_expr e2 + | SESP.ExprTERNARY(_,(e1,e2,e3)) -> + Format.fprintf ff "(%a ? %a : %a)" + fmt_expr e1 fmt_expr e2 fmt_expr e3 + | SESP.ExprNARY(SESP.ARRAY_INIT, ee) -> + Format.fprintf ff "([%a])" + (List.fmt "," fmt_expr) (Array.to_list ee) + | SESP.ExprNARY(SESP.STRUCT_INIT, ee) -> + Format.fprintf ff "({%a})" + (List.fmt "," fmt_expr) (Array.to_list ee) + +let rec fmt_type ff t = + let open SESP in + match Type.refine t with + | TypeUnknown -> Format.fprintf ff "unknown" + | TypeVoid -> Format.fprintf ff "void" + | TypeBool -> Format.fprintf ff "bool" + | TypeChar(unsigned,_size) -> + Format.fprintf ff "%s char" (if unsigned then "unsigned" else "" ) + | TypeInteger(unsigned,_size) -> + Format.fprintf ff "%s int" (if unsigned then "unsigned" else "" ) + | TypeFloatingPoint(_size) -> Format.fprintf ff "float" + | TypeModifier((const,vol),ty') -> + Format.fprintf ff "%s %s %a" + (if const then "const" else "") + (if vol then "volatile" else "") + fmt_type ty' + | TypePointer(ty') -> Format.fprintf ff "*%a" fmt_type ty' + | TypeCXXReference(ty') -> Format.fprintf ff "%a &" fmt_type ty' + | TypeCXXArray(ty',Some size) -> + Format.fprintf ff "%a[%d]" fmt_type ty' size + | TypeCXXArray(ty',None) -> + Format.fprintf ff "%a[]" fmt_type ty' + | TypeEnum(id,ty') -> + Format.fprintf ff "enum %s %a" + (Symb.undecoratedname id) fmt_type ty' + | TypeAlias(id,ty') -> + Format.fprintf ff "typedef %a %s" + fmt_type ty' (Symb.undecoratedname id) + | TypeClass(id,aggr) -> + Format.fprintf ff "class %s { %a } " + (Symb.undecoratedname id) fmt_ctype_aggr aggr + | TypeStruct(id,aggr) -> + Format.fprintf ff "struct %s { %a } " + (Symb.undecoratedname id) fmt_ctype_aggr aggr + | TypeUnion(id,aggr) -> + Format.fprintf ff "union %s { %a } " + (Symb.undecoratedname id) fmt_ctype_aggr aggr + | TypeFunction(f) -> Format.fprintf ff "%a" fmt_ctype_func f + | TypeMethod(m) -> Format.fprintf ff "%a" fmt_ctype_func m + +and fmt_ctype_aggr ff aggr = + let flds = Array.to_list (SESP.Type.fields aggr) in + Format.fprintf ff "%a" (List.fmt ";" fmt_symb) flds + +and fmt_ctype_func ff f = + let ret = SESP.Type.returns f in + let args,_varg = SESP.Type.arguments f in + Format.fprintf ff "%a -> %a" + (List.fmt "->" fmt_type) (Array.to_list args) + fmt_type ret + +let rec fmt_node ff node = + let n_id = SESP.Node.id node in + match SESP.Node.refine node with + | SESP.Entry(succ,_pre) -> Format.fprintf ff "%d:Entry(%d)" n_id (SESP.Node.id succ) + | SESP.Exit(_post) -> Format.fprintf ff "%d:Exit" n_id + | SESP.ExceptionExit -> Format.fprintf ff "%d:ExceptionExit" n_id + | SESP.Pattern(_) -> Format.fprintf ff "Pattern" + | SESP.Event -> Format.fprintf ff "Event" + | SESP.Call(schema, args, _call_retn, _call_unwind, _pre, _post) -> + let args = Array.to_list args in + (match schema with + | (SESP.Direct symb) -> + Format.fprintf ff "%d:@ DirectCall(%s, @[%a@],_) " + n_id (SESP.Symb.undecoratedname symb) (List.fmt "," fmt_expr) args + | (SESP.Indirect fp) -> + Format.fprintf ff "%d:@ InDirectCall(%a, @[%a@],_) " + n_id fmt_expr fp (List.fmt "," fmt_expr) args + | SESP.DirectMethod(symb) -> + Format.fprintf ff "%d:@ DirectMethod(%s, @[%a@],_) " + n_id (SESP.Symb.undecoratedname symb) (List.fmt "," fmt_expr) args + | SESP.IndirectMethod(fp) -> + Format.fprintf ff "%d:@ InDirectMethod(%a, @[%a@],_) " + n_id fmt_expr fp (List.fmt "," fmt_expr) args + | SESP.Virtual(symb) -> + Format.fprintf ff "%d:@ Virtual(%s, @[%a@],_) " + n_id (SESP.Symb.undecoratedname symb) (List.fmt "," fmt_expr) args + | SESP.Intrinsic(symb) -> + Format.fprintf ff "%d:@ Intrinsic(%s, @[%a@],_) " + n_id (SESP.Symb.undecoratedname symb) (List.fmt "," fmt_expr) args + ) + | SESP.CallReturn(pe_o, None) -> + Format.fprintf ff "%d:@ CallReturn(%a, None)" + n_id (Option.fmt "None" fmt_expr) pe_o + | SESP.CallReturn(pe_o, Some succ) -> + Format.fprintf ff "%d:@ CallReturn(%a, %d)" + n_id (Option.fmt "None" fmt_expr) pe_o + (SESP.Node.id succ) + | SESP.CallUnwind(_n) -> Format.fprintf ff "CallUnwind" + | SESP.Decl(s,ty,succ) -> Format.fprintf ff "%d:Decl(%s,%a,%d)" + n_id (SESP.Symb.undecoratedname s) fmt_type ty (SESP.Node.id succ) + | SESP.StaticDeclBegin(_s,_ct,_n) -> Format.fprintf ff "StaticDeclBegin" + | SESP.StaticDeclEnd(_n) -> Format.fprintf ff "StaticDeclBegin" + | SESP.Endscope -> Format.fprintf ff "Endscope" + | SESP.Throw(_n) -> Format.fprintf ff "Throw" + | SESP.RaiseException -> Format.fprintf ff "RaiseException" + | SESP.CatchBegin(_n) -> Format.fprintf ff "CatchBegin" + | SESP.CatchEnd(_n) -> Format.fprintf ff "CatchEnd" + | SESP.Branch(pe, n1, n2) -> + Format.fprintf ff "%d:@ Branch(%a, %i, %i)" + n_id fmt_expr pe (SESP.Node.id n1) (SESP.Node.id n2) + | SESP.Switch(pe1, label_bodys, default) -> + let label_bodys = Array.to_list label_bodys in + let rec loop label_bodys = + match label_bodys with + | [] -> () + | (label,body) :: rest -> + (Format.fprintf ff "case(%a): %i; " + fmt_expr label (SESP.Node.id body)) ; + loop rest + in + Format.fprintf ff "Switch(%a)" fmt_expr pe1 ; + (loop label_bodys) ; + (Format.fprintf ff "default(%i)" (SESP.Node.id default)) + | SESP.Expression(pe_o, None) -> + Format.fprintf ff "%d:@ Expression(%a, NOHALT)" + n_id (Option.fmt "None" fmt_expr) pe_o + | SESP.Expression(pe_o, Some succ) -> + Format.fprintf ff "%d:@ Expression(%a, %d)" + n_id (Option.fmt "None" fmt_expr) pe_o (SESP.Node.id succ) + | SESP.Return(pe, exit) -> + Format.fprintf ff "%d:@ Return(%a, %d)" + n_id fmt_expr pe (SESP.Node.id exit) + | SESP.Assume(n, _) -> + Format.fprintf ff "%d:@ Assume(%a)" + n_id fmt_node n + | SESP.Verify(n, _) -> + Format.fprintf ff "%d:@ Verify(%a)" + n_id fmt_node n + | SESP.Asm(_succ) -> Format.fprintf ff "Asm" + | SESP.Nop(succ) -> Format.fprintf ff "%d:Nop(%d)" n_id (SESP.Node.id succ) + + +(*****************************************************************************) +(* Hard-coded names *) +(*****************************************************************************) +let proc_is_agg_static_init n = n = "aggregate_static_initializer" +let proc_is_agg_dyn_init n = n = "aggregate_dynamic_initializer" + + +(*****************************************************************************) +(* Heapification *) +(*****************************************************************************) + +(* Calculate vars to heapify. We heapify: + (1) globals of aggregate type; + (2) locals of aggregate type; + (3) locals whose address is taken. + (4) Addresses of functions. + (5) Formals whose address is taken + (6) Structs that are passed by copying.*) +type heapify_tag = HGlobal | HLocalStruct | HAddrOfLocal | HAddrOfFunc | HFormal | HFormalStruct + +let to_heapify_type ty = + (fun b -> L.printf 6 "to_heapify_type (%a) = %b" fmt_type ty b) + <& + let open SESP in + match get_type ty with + | TypeStruct(_) + | TypeUnion(_) + | TypeCXXArray(_) -> true + | _ -> false + +let heapify_type ty = + match Typ.desc ty with + (* Heapification does not change the type of arrays, + but ESP has already wrapped & around every array-typed expr. *) + | Typ.Array(_) -> ty + | _ -> Typ.mkPointer (ty) + +let to_heapify_acc global_pred cfg vars_to_heapify = + let open SESP in + let fn_symb symb tbl = + if Symb.kind symb = ESP.ESP_IR_SK_GLOBAL && global_pred symb then ( + L.printf 6 "heapify %a G" fmt_symb symb ; + SymbHMap.add tbl symb HGlobal + ) + else if to_heapify_type (Symb.ctype symb) then ( + let open ESP in + if Symb.kind symb = ESP_IR_SK_FORMAL + || (Symb.kind symb = ESP_IR_SK_RETURN_VALUE && Some(symb) = (Cfg.formal_return cfg)) + then ( + L.printf 6 "heapify %a FS" fmt_symb symb ; + SymbHMap.add tbl symb HFormalStruct + ) + else if Symb.kind symb = ESP_IR_SK_LOCAL + || Symb.kind symb = ESP_IR_SK_RETURN_VALUE + || Symb.kind symb = ESP_IR_SK_TEMPORARY + then ( + L.printf 6 "heapify %a LS" fmt_symb symb ; + SymbHMap.add tbl symb HLocalStruct + ) + else + L.printf 1 "heapify %a unexpected kind: %s" fmt_symb symb (Symb.kind_as_string symb) + ); + tbl + in + let fn_expr expr tbl = + (match Expr.refine expr with + | ExprUNARY(ADDRESS, e0) -> + (match Expr.refine e0 with + | ExprLEAF(SYMBOL(symb)) -> + let open ESP in + (match Symb.kind symb with + | ESP_IR_SK_LOCAL -> + L.printf 6 "heapify %a &L" fmt_symb symb ; + SymbHMap.add vars_to_heapify symb HAddrOfLocal + | ESP_IR_SK_FUNCTION -> + L.printf 6 "heapify %a &F" fmt_symb symb ; + SymbHMap.add vars_to_heapify symb HAddrOfFunc + | ESP_IR_SK_GLOBAL -> + L.printf 6 "heapify %a &G" fmt_symb symb ; + SymbHMap.add vars_to_heapify symb HGlobal + | ESP_IR_SK_FORMAL -> + L.printf 6 "heapify %a &FO" fmt_symb symb ; + SymbHMap.add vars_to_heapify symb HFormal + | _ -> + failwithf "Unexpected address-of symbol %a of kind %s" fmt_symb symb (Symb.kind_as_string symb) + ) + | _ -> + () + ) + | _ -> + () + ); + tbl + in + let fn_node _node tbl = + tbl + in + fold_cfg fn_symb fn_expr fn_node cfg vars_to_heapify + +let to_heapify global_pred cfg = + to_heapify_acc global_pred cfg (SymbHMap.create 255) + +let to_heapify_cfgs global_pred cfgs = + StringHMap.fold (fun _ -> to_heapify_acc global_pred) cfgs (SymbHMap.create 255) + +end (* module SESPExt *) + + +(*****************************************************************************) +(* Symbol management for linking *) +(*****************************************************************************) + +let of_symb mk = + let tbl = StringHMap.create 1024 in + fun symb meta -> + let globally_unique_name = SESP.Symb.name symb in + let name = SESP.Symb.undecoratedname symb in + try + StringHMap.find tbl globally_unique_name + with Not_found -> + let res = mk name meta in + StringHMap.add tbl globally_unique_name res ; + res + +let var_of = of_symb Var.gensym + +let proc_of = + let closure = of_symb (fun name () -> Proc.Id.gensym name) in + fun symb -> closure symb () + + +(*****************************************************************************) +(* Program data structure functions. *) +(*****************************************************************************) + +let mkLoad x e p = I.mk (I.Load(x,e)) p +let mkStore e f p = I.mk (I.Store(e,f)) p + +let mkKills vs pos blk = I.mk (I.Kill(vs)) pos :: blk + +let mkKill v pos blk = mkKills (Vars.singleton v) pos blk + +let mkMove x e p = I.mk (I.Move(x,e)) p + +let mkAlloc pos v ty = + L.printf 4 "heap_vars %a" Var.fmt v ; + match Typ.desc ty with + | Typ.Array _ -> + [ I.mk (I.Alloc(v, E.mkNum(Typ.sizeof ty))) pos ] + | _ -> + [ I.mk (I.Alloc(v, E.mkNum(Typ.sizeof ty))) pos + ; I.mk (I.Cast(v, Typ.mkPointer ty, E.mkVar v)) pos ] + +let mkFree pos v = I.mk (I.Free(E.mkVar v)) pos + +let no_insts = [] +let mkNop pos = C.Inst(I.mk I.Nop pos) + + +(*****************************************************************************) +(* Translation of types *) +(*****************************************************************************) + +let isStructUnion ety = + match SESP.Type.refine ety with + | SESP.TypeStruct(_,_) | SESP.TypeUnion(_,_) -> true + | _ -> false + +module TypeHMap = HashMap.Make (struct + type t = SESP.ctype + let equal x y = + Pervasives. (==) x y || SESP.Type.types_equal x y + let hash = Hashtbl.hash +end) + +(* Keep track of recursive types. *) +let ctype_memo : Typ.t option TypeHMap.t = TypeHMap.create 101 + +let fld_tbl = PolyHMap.create 1024 + +let off_of_ctype_member member = + let fo = Option.from_some (SESP.Symb.get_field_offset member) in + if SESP.Symb.is_bit_field member then + (fo, SESP.Symb.get_bit_field_offset member) + else + (fo, None) + +let rec type_of_esp_type ety = + L.incf 8 "( xlate_type %s" (SESP.Type.to_string ety) ; + L.decf 8 ") xlate_type: %a" Typ.fmt + <& + match TypeHMap.tryfind ctype_memo ety with + | None -> (* [ety] not yet xlated *) + L.printf 10 "+ NotYetXlated" ; + (* only memoize aggregates so that the hack that breaks cycles with Top does not hide Ptr types *) + if(isStructUnion ety) then TypeHMap.add ctype_memo ety None ; + let size = Int64.of_int (SESP.Type.sizeof_size ety) in + let ty' = + (match SESP.Type.refine ety with + | SESP.TypeUnknown -> failwith "Can't xlate SESP.TypeUnknown" + | SESP.TypeVoid -> Typ.mkTop + | SESP.TypeBool -> Typ.mkBool + | SESP.TypeChar(u,s) + | SESP.TypeInteger(u,s) -> Typ.mkInt u s + | SESP.TypeFloatingPoint(s) -> Typ.mkFloat s + | SESP.TypeModifier((_,_),t) -> type_of_esp_type t + | SESP.TypePointer p -> Typ.mkPointer(type_of_esp_type p) + | SESP.TypeCXXReference p -> Typ.mkPointer(type_of_esp_type p) + | SESP.TypeCXXArray(a, len) -> + Typ.mkArray (type_of_esp_type a) (Option.map Int64.of_int len) size + |(SESP.TypeStruct(id,aggr_info) + | SESP.TypeUnion(id,aggr_info)) as ty -> + let aggr_name = SESP.Symb.name id in + let fld_typs = + Array.fold_right (fun member fld_typs -> + let name = SESP.Symb.undecoratedname member in + let off = off_of_ctype_member member in + let fld = Fld.mk off name in + let typ = type_of_esp_type (SESP.Symb.ctype member) in + (fld, typ) :: fld_typs + ) (SESP.Type.fields aggr_info) [] + in + let typ = + match ty with + | SESP.TypeStruct _ -> Typ.mkStructure aggr_name fld_typs size + | SESP.TypeUnion _ -> Typ.mkUnion aggr_name fld_typs size + | _ -> assert false + in + (match Typ.desc typ with + | Typ.Structure(_,fts,_) | Typ.Union(_,fts,_) -> + List.iter (fun (f,_) -> + PolyHMap.add fld_tbl (ety, Fld.off f) f + ) fts + | _ -> () + ); + typ + | SESP.TypeEnum(_, underlying_ty) -> type_of_esp_type underlying_ty + | SESP.TypeAlias(_, t) -> type_of_esp_type t + | SESP.TypeFunction(t) -> + let (arguments_array, vararg) = SESP.Type.arguments t in + let return_type = SESP.Type.returns t in + Typ.mkFunction (type_of_esp_type return_type) + (List.map (fun ty -> (type_of_esp_type ty)) + (Array.to_list arguments_array)) + vararg + | SESP.TypeClass _ | SESP.TypeMethod _ -> failwith "May call Type of C++" + ) + in + if (isStructUnion ety) then TypeHMap.add ctype_memo ety (Some ty') ; + ty' + + | Some (None) -> (* ety being xlated, we're in a cycle. *) + L.printf 10 "+ InACycle" ; + Typ.mkTop (* break the recursion *) + + | Some (Some(ty)) -> (* ety already xlated *) + L.printf 10 "+ AlreadyXlated" ; + ty + + +(* ESP does not ensure uniqueness of names of field symbols, + so identify them by their enclosing type and offset *) +let fld_of typ symb = + let rec get_aggregate typ = + match SESP.Type.refine typ with + | SESP.TypeStruct _ | SESP.TypeUnion _ -> + typ + | SESP.TypePointer(typ) | SESP.TypeCXXReference(typ) + | SESP.TypeModifier(_,typ) | SESP.TypeAlias(_,typ) -> + get_aggregate typ + | _ -> + failwithf "aggregate type expected: %s" (SESP.Type.to_string typ) + in + (* ensure typ is translated before trying to look up its fields *) + let _ = type_of_esp_type typ in + let typ = get_aggregate typ in + let off = off_of_ctype_member symb in + PolyHMap.find fld_tbl (typ, off) + + +(*****************************************************************************) +(* Copy of SESP.Expr data structure. *) +(*****************************************************************************) + +(* + I think I need to the heapification on some source (Esp.Expr) data + structure. Both fe_slam and fe_cil did this on PExpr.Loc and Cil.Expr + respectively. But I can't ctor SESP.Expr, or even ctor SESP.expr_schema, + as SESP exposes no expr ctors for me. Hence this copy of SESP.Expr. +*) + +module Expr = struct + + type convert_type = + | Convert_PTR_UNRELATED + | Convert_REINTERPRET + | Convert_WIDEN + | Convert_NARROW + | Convert_FLOATING + + type expr_desc = + | ExprConstInt of int64 + | ExprConstFloat of float + | ExprConstString of int * string * bool + | ExprSymb of SESP.symb + | ExprSymbSlayer of Var.t (* Used to allow creation of new intermediates *) + | ExprAddr of expr + | ExprDeref of expr + | ExprDot of expr * SESP.symb + | ExprNegate of expr + | ExprUplus of expr + | ExprNot of expr + | ExprBitNot of expr + | ExprConvert of convert_type * expr + | ExprAssign of SESP.expr_schema_BINARY option * expr * expr + (* SI: missing other ASSIGNs *) + | ExprIncr of SESP.expr_schema_INCREMENT * expr * expr + | ExprCompare of SESP.expr_schema_COMPARE * expr * expr + | ExprBinary of SESP.expr_schema_BINARY * expr * expr + (* | SESP.ExprTERNARY(_, (_, _, _)) -> *) + | ExprArrayInit of expr list + | ExprStructInit of expr list + (* Used for encoding some complex features *) + | ExprSeq of expr list + (* SI: There're segfaults if we immediately translate Expr.ctype to + Typ.t. So, instead we keep SESP.ctype. [heapify_expr] sets + var_heapified, so that [type_of_expr] returns the right type. *) + and expr = { + desc : expr_desc; + var_heapified : bool; + ty : SESP.ctype; + (* ty : Typ.t *) + } + + + (* Printer *) + let rec fmt_expr ff e = + match e.desc with + | ExprConstInt(i) -> Format.fprintf ff "(%Ld)" i + | ExprConstFloat(f) -> Format.fprintf ff "(%f)" f + | ExprConstString(_,s,_) -> Format.fprintf ff "(\"%s\")" s + | ExprSymb(symb) -> Format.fprintf ff "(%a)" SESPExt.fmt_symb symb + | ExprSymbSlayer(var) -> Format.fprintf ff "(%a)" Var.fmt var + | ExprAddr(e0) -> Format.fprintf ff "(& %a)" fmt_expr e0 + | ExprDeref(e0) -> Format.fprintf ff "(*%a)" fmt_expr e0 + | ExprDot(e0, fld) -> Format.fprintf ff "(%a.%a)" fmt_expr e0 SESPExt.fmt_symb fld + | ExprNegate(e0) -> Format.fprintf ff "(- %a)" fmt_expr e0 + | ExprUplus(e0) -> Format.fprintf ff "(+ %a)" fmt_expr e0 + | ExprNot (e0) -> Format.fprintf ff "(! %a)" fmt_expr e0 + | ExprBitNot(e0) -> Format.fprintf ff "(~ %a)" fmt_expr e0 + | ExprConvert(_t,e0) -> Format.fprintf ff "((T) %a)" fmt_expr e0 + | ExprAssign(op, lhs,rhs) -> Format.fprintf ff "(%a %a= %a)" fmt_expr lhs (Option.fmt "" (SESPExt.fmt_binary_op)) op fmt_expr rhs + | ExprIncr(op,e0,_e1) -> ( + match op with + | SESP.PREINCR | SESP.PREDECR -> + Format.fprintf ff "(%a %a)" + SESPExt.fmt_increment_op op fmt_expr e0 + | SESP.POSTINCR | SESP.POSTDECR -> + Format.fprintf ff "(%a %a)" + fmt_expr e0 SESPExt.fmt_increment_op op) + | ExprCompare(op,e0,e1) -> Format.fprintf ff "(%a %a %a)" + fmt_expr e0 SESPExt.fmt_compare_op op fmt_expr e1 + | ExprBinary(op,e0,e1) -> + Format.fprintf ff "(%a %a %a)" + fmt_expr e0 SESPExt.fmt_binary_op op fmt_expr e1 + | ExprArrayInit(ee) -> Format.fprintf ff "[%a]" (List.fmt "," fmt_expr) ee + | ExprStructInit(ee) -> Format.fprintf ff "{%a}" (List.fmt "," fmt_expr) ee + | ExprSeq(ee) -> Format.fprintf ff "(@[%a@])" (List.fmt ";@ " fmt_expr) ee + let fmt_expr_typ ff e = +(* Format.fprintf ff "%a : %s" fmt_expr e (SESP.Type.to_string e.ty) *) + Format.fprintf ff "%a:" fmt_expr e + + + (* Vanilla constructors and destructors *) + let mk_expr desc ?(var_heapified=false) ty = { desc; ty; var_heapified; } + + (* Make an assignment expression, deals with expanding a struct copy is required. *) + let mk_expr_assign op lhs rhs = + let rec mk_expr_assign lhs rhs = + let ty = lhs.ty in + match SESPExt.get_type ty with + | SESP.TypeStruct _ -> + mk_member_assign lhs rhs + | _ -> + mk_expr (ExprAssign(op, lhs, rhs)) ty + + and mk_member_assign lhs rhs = + let ty = lhs.ty in + match SESPExt.get_type ty, rhs.desc with + | SESP.TypeStruct _, ExprAssign _ -> + failwith "Unsupported nested struct assignment" + | SESP.TypeStruct(_id, aggr_info), _ -> + assert( op = None ); + let ee = + Array.fold_right (fun member assigns -> + let lhs = mk_expr (ExprDot(lhs, member)) (SESP.Symb.ctype member) in + let rhs = mk_expr (ExprDot(rhs, member)) (SESP.Symb.ctype member) in + (mk_member_assign lhs rhs) :: assigns + ) (SESP.Type.fields aggr_info) [] in + mk_expr (ExprSeq ee) ty + | SESP.TypeCXXArray _, ExprArrayInit _ -> + mk_expr (ExprAssign(op, lhs, rhs)) ty + | SESP.TypeCXXArray(ety, Some len), _ -> + (* This only occurs as a part of structure copy *) + let ee = ref [] in + for i = len - 1 downto 0 do + (* WARNING: The type of index should be integer, but there is no way to construct the appropriate + symbol. The translation of ExprConstInt does not look at the type so we put in garbage here! *) + let index = mk_expr (ExprConstInt(Int64.of_int i)) ety in + let lhs = mk_expr (ExprBinary(SESP.INDEX, lhs, index)) ety in + let rhs = mk_expr (ExprBinary(SESP.INDEX, rhs, index)) ety in + ee := (mk_member_assign lhs rhs) :: !ee + done; + mk_expr (ExprSeq !ee) ty + | _ -> + mk_expr (ExprAssign(op, lhs, rhs)) ty + in + mk_expr_assign lhs rhs + + + let type_of_expr (e:expr) : Typ.t = + let typ = type_of_esp_type e.ty in + if e.var_heapified then SESPExt.heapify_type typ + else typ + + + (* Translate Esp.Expr to expr *) + let rec expr_of_EspExpr ee = + L.incf 8 "( expr_of_Esp.Expr %a" SESPExt.fmt_expr ee ; + let ty = SESP.Expr.ctype ee in +(* let ty = type_of_esp_type ty in *) + let e = ( + match SESP.Expr.refine ee with + (* LEAF *) + | SESP.ExprLEAF(SESP.NOP) -> failwith("LEAF(NOP)") + | SESP.ExprLEAF(SESP.CONSTANT i) -> mk_expr (ExprConstInt(i)) ty + | SESP.ExprLEAF(SESP.FLOAT f) -> mk_expr (ExprConstFloat(f)) ty + | SESP.ExprLEAF(SESP.STRING (len, str, w)) -> mk_expr (ExprConstString(len,str,w)) ty + | SESP.ExprLEAF(SESP.FIELD) -> failwith("LEAF(FIELD)") + | SESP.ExprLEAF(SESP.SYMBOL symb) -> mk_expr (ExprSymb(symb)) ty + | SESP.ExprLEAF(SESP.CURRENTEXCEPTION) -> failwith("LEAF(CURRENTEXCEPTION)") + | SESP.ExprLEAF(SESP.NEWOBJ) -> failwith("LEAF(NEWOBJ)") + | SESP.ExprLEAF(SESP.TYPEID_TYPE) -> failwith("LEAF(TYPEID_TYPE)") + | SESP.ExprUNARY(SESP.ADDRESS, ee0) -> mk_expr (ExprAddr(expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.DEREF, ee0) -> mk_expr (ExprDeref(expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.DOT, ee0) -> ( + match SESP.Expr.field ee with + | Some fld -> + mk_expr (ExprDot(expr_of_EspExpr ee0, fld)) (SESP.Symb.ctype fld) + | None -> failwith "Dot has no field") + | SESP.ExprUNARY(SESP.ARROW, p) -> ( + match SESP.Expr.field ee with + | Some fld -> + let p_ty = SESP.Expr.ctype p in + let p = expr_of_EspExpr p in + let star_p = mk_expr (ExprDeref(p)) p_ty in + mk_expr (ExprDot(star_p, fld)) (SESP.Symb.ctype fld) + | None -> failwith "Arrow has no field") + | SESP.ExprUNARY(SESP.CXXCATCHTEST, _ee0) -> failwith("UNARY(CXXCATCHTEST)") + | SESP.ExprUNARY(SESP.NEGATE, ee0) -> mk_expr (ExprNegate(expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.UPLUS, ee0) -> mk_expr (ExprUplus(expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.NOT, ee0) -> mk_expr (ExprNot(expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.BITNOT, ee0) -> mk_expr (ExprBitNot(expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.CONVERT_PTR_UNRELATED,ee0) -> + mk_expr (ExprConvert(Convert_PTR_UNRELATED, expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.CONVERT_REINTERPRET, ee0) -> + mk_expr (ExprConvert(Convert_REINTERPRET, expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.CONVERT_WIDEN,ee0) -> + mk_expr (ExprConvert(Convert_WIDEN, expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.CONVERT_NARROW, ee0) -> + mk_expr (ExprConvert(Convert_NARROW, expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.CONVERT_FLOATING,ee0) -> + mk_expr (ExprConvert(Convert_FLOATING, expr_of_EspExpr ee0)) ty + | SESP.ExprUNARY(SESP.NEWARRAY, _ee0) + | SESP.ExprUNARY(SESP.ARRAYLENGTH, _ee0) -> failwith("UNARY(C# array)") + | SESP.ExprUNARY(SESP.BOX, _ee0) + | SESP.ExprUNARY(SESP.UNBOX, _ee0) -> failwith("UNARY(C# boxing)") + | SESP.ExprUNARY(SESP.DYNAMICCAST, _ee0) -> failwith("UNARY(DYNAMICCAST)") + | SESP.ExprUNARY(SESP.TYPEID_EXPR, _ee0) -> failwith("UANRY(TYPEID_EXPR)") + | SESP.ExprUNARY(SESP.UNARY, _ee0) -> failwith("UNARY(UNARY)") + | SESP.ExprASSIGN(op, (lhs,rhs)) -> + mk_expr_assign (SESPExt.assign_op_conv op) (expr_of_EspExpr lhs) (expr_of_EspExpr rhs) + | SESP.ExprINCREMENT (op, (e0, e1)) -> + mk_expr (ExprIncr(op, expr_of_EspExpr e0, expr_of_EspExpr e1)) ty + | SESP.ExprCOMPARE(op, (ee0, ee1)) -> + mk_expr (ExprCompare(op, expr_of_EspExpr ee0, expr_of_EspExpr ee1)) ty + | SESP.ExprBINARY(op, (ee0, ee1)) -> + mk_expr (ExprBinary(op, expr_of_EspExpr ee0, expr_of_EspExpr ee1)) ty + | SESP.ExprTERNARY(_, (_, _, _)) -> failwith("TERNARY") + | SESP.ExprNARY(SESP.ARRAY_INIT, ee) -> + mk_expr (ExprArrayInit(List.map expr_of_EspExpr (Array.to_list ee))) ty + | SESP.ExprNARY(SESP.STRUCT_INIT, ee) -> + mk_expr (ExprStructInit(List.map expr_of_EspExpr (Array.to_list ee))) ty + ) in + e + &> (fun e -> L.decf 8 ") %a" fmt_expr e) + + + (* Transform e so that vars_to_heap vars are accessed as though they + are on the heap, not on the stack. Leave & in for now, xlate_expr_rv + will translate only valid &*e exprs. + SI: Review. + *) + let heapify_expr vars_to_heap e = + L.incf 8 "( heapify %a" fmt_expr e ; + let rec heapify e = + match e.desc with + | ExprConstInt(_) -> e + | ExprConstFloat(_) -> e + | ExprConstString(_) -> e (* SI: we'll come back to const string *) + | ExprSymbSlayer(_) -> e (* Assume heapified correctly by creation *) + | ExprSymb(symb) -> + if SESPExt.SymbHMap.mem vars_to_heap symb then + (* Transform s:T into s : Ptr(T); return Deref(s) : T. *) + (* Heapification does not change the type of arrays, + but ESP has already wrapped & around every array-typed expr, + so add a Deref also around heapified array vars. *) + mk_expr (ExprDeref({ e with var_heapified= true })) e.ty + else + e + | ExprAddr(e0) -> { e with desc= ExprAddr(heapify e0) } + | ExprDeref(e0) -> { e with desc= ExprDeref(heapify e0) } + | ExprDot(e0, fld) -> + { e with desc= ExprDot(heapify e0, fld) } + | ExprNegate(e0) -> + { e with desc= ExprNegate(heapify e0) } + | ExprUplus(e0) -> + { e with desc= ExprUplus(heapify e0) } + | ExprNot(e0) -> + { e with desc= ExprNot(heapify e0) } + | ExprBitNot(e0) -> + { e with desc= ExprBitNot(heapify e0) } + | ExprConvert(t, e0) -> + { e with desc= ExprConvert(t, heapify e0) } + | ExprAssign(op, lhs, rhs) -> + { e with desc= ExprAssign(op, heapify lhs, heapify rhs) } + | ExprIncr(op, e0, e1) -> + { e with desc= ExprIncr(op, heapify e0, heapify e1) } + | ExprCompare(op, e0, e1) -> + { e with desc= ExprCompare(op, heapify e0, heapify e1) } + | ExprBinary(op, e0, e1) -> + { e with desc= ExprBinary(op, heapify e0, heapify e1) } + | ExprArrayInit(ee) -> + { e with desc= ExprArrayInit(List.map heapify ee) } + | ExprStructInit(ee) -> + { e with desc= ExprStructInit(List.map heapify ee) } + | ExprSeq(ee) -> + { e with desc= ExprSeq(List.map heapify ee)} + in + heapify e + &> (fun e -> L.decf 8 ") : %a" fmt_expr e) + + +end (* module Expr *) + + + + +(*****************************************************************************) +(* Translate ESP source_location to SIL position *) +(*****************************************************************************) +let xlate_pos = function + | Some(file,line) -> + let dir = Filename.dirname file in + let file = Filename.basename file in + let col = 0 in + {Position.dir; file; line; col} + | None -> + {Position.dir= "none"; file= "none"; line= 0; col= 0} + + +(*****************************************************************************) +(* "Constants" *) +(*****************************************************************************) + +(* Prefix for names of temporary variables introduced by frontend. *) +let temp_prefix = "temp" + + +(*****************************************************************************) +(* Temporary variables generated for RValue evaluation. *) +(*****************************************************************************) + +let tmps : Var.t SESPExt.CfgHMMap.t = SESPExt.CfgHMMap.create 31 + +let mk_tmp ?(prefix=temp_prefix) cfg sort = + let tmp = Var.gensym prefix sort in + L.printf 8 "adding tmp %a for cfg %s" Var.fmt tmp (SESP.Symb.name cfg) ; + SESPExt.CfgHMMap.add tmps cfg tmp ; + tmp + + + +(*****************************************************************************) +(* Translate esp identifiers *) +(*****************************************************************************) + +(* (Memoized) translate ESP.symb to Var.t. *) + +type var_kind = VarKFun | VarKGlobal | VarKFormal | VarKReturn | VarKLocal | VarKTmp + +(* Translate symb:ty. Memoize in appropriate $ ([globals] or [locals]). *) +let var_of_symb globals locals ty symb = try + match SESPExt.SymbHMap.tryfind locals symb with + | Some (v,_k,ty') -> assert(Typ.equal ty' ty); v + | None -> + match SESPExt.SymbHMap.tryfind globals symb with + | Some (v,_k,ty') -> assert(Typ.equal ty' ty); v + | None -> + let v = var_of symb (Var.sort_of_type ty) in + let kind = + match SESP.Symb.kind symb with + | ESP.ESP_IR_SK_FUNCTION -> VarKFun + | ESP.ESP_IR_SK_CTOR -> + L.printf 4 "Ctor translated as function" ; VarKFun + | ESP.ESP_IR_SK_DTOR -> + L.printf 4 "Dtor translated as function" ; VarKFun + | ESP.ESP_IR_SK_GLOBAL -> VarKGlobal + | ESP.ESP_IR_SK_FORMAL -> VarKFormal + | ESP.ESP_IR_SK_FORMAL_VARARGS -> + failwith "var_of_symb of FORMAL_VARARGS" + | ESP.ESP_IR_SK_LOCAL -> VarKLocal + | ESP.ESP_IR_SK_TEMPORARY -> + (* SI: These are ESP temps. We use mk_tmp for SLAyer's own tmps.*) + VarKTmp + | ESP.ESP_IR_SK_RETURN_VALUE -> VarKReturn + | ESP.ESP_IR_SK_TYPENAME + | ESP.ESP_IR_SK_FIELD + | ESP.ESP_IR_SK_BASECLASS + | ESP.ESP_IR_SK_VIRTUAL_BASECLASS -> + failwith "var_of_symb of non-variable" + in + (match kind with + | VarKFun | VarKGlobal -> SESPExt.SymbHMap.add globals symb (v,kind,ty) + | VarKFormal | VarKLocal | VarKTmp -> SESPExt.SymbHMap.add locals symb (v,kind,ty) + | VarKReturn -> () + ); + v + + with exc -> L.printf 0 "var_of_symb: %s" (SESP.Symb.name symb) ; raise exc + + +(* Not sure we need as much as espcu's sesp_symb_to_slam_pureName_aux. + (We don't want to to do C++ right now.) + But we should use linkage in this. *) +let symb_name symb = + SESP.Symb.name symb + + + +(*============================================================================ + + Compile Expr to E.t. + + Also return the supporting set of insts that prefix the E.t, and the + set of kills that'll post-fix it. + + ============================================================================*) + +(** ExprStructInit has a list of exprs. We translate each of these, + and store them temporarily in a E.OpN(E.UFun("name"),...). *) + +let struct_init_func_name = "StructInit" +let array_init_func_name = "ArrayInit" + +(** is-a type *) +let rec is_array cty = + let open SESP in + L.printf 10 "is_array %s = %b" (Type.to_string cty) <& + match Type.refine cty with + | TypeCXXArray _ -> true + | TypeAlias(_,cty) -> is_array cty + | _ -> false + +let rec is_ptr cty = + let open SESP in + L.printf 10 "is_ptr %s = %b" (Type.to_string cty) <& + match Type.refine cty with + | TypePointer _ -> true + | TypeAlias(_,cty) -> is_ptr cty + | _ -> false + +let is_pchar cty = + let open SESP in + match SESPExt.get_type cty with + | TypePointer(cty) -> + (match SESPExt.get_type cty with + | TypeChar _ -> true + | _ -> false + ) + | _ -> + false + +let get_struct_of_pstruct cty = + let open SESP in + match SESPExt.get_type cty with + | TypePointer(cty) -> + (match SESPExt.get_type cty with + | TypeStruct _ | TypeUnion _ -> Some(cty) + | _ -> None + ) + | _ -> + None + + +type lvalue = Reg of Var.t | Adr of Exp.t + +let fmt_lvalue ff = function + | Reg(v) -> Var.fmt ff v + | Adr(a) -> Exp.fmt ff a + + +let fmt_blk = List.fmt ";@ " I.fmt + + +let xlate_binary_op op e0 e1 = + match op with + | SESP.INDEX -> + E.mkIdx e0 e1 + | SESP.PLUS -> + if E.is_pointer e0 + then E.mkIdx e0 e1 + else E.mkZAdd [|e0 ; e1|] + | SESP.MINUS -> + if E.is_pointer e0 + then E.mkIdx e0 (E.mkZMin e1) + else E.mkZSub [|e0 ; e1|] + | SESP.MULT -> + E.mkZMul [|e0 ; e1|] + | SESP.DIV -> + E.mkZDiv e0 e1 + | SESP.REM -> + E.mkZRem e0 e1 + | SESP.BITAND -> + E.mkUFun ("&") [|e0;e1|] + | SESP.BITOR -> + E.mkUFun ("|") [|e0;e1|] + | SESP.XOR -> + E.mkUFun ("^") [|e0;e1|] + | SESP.LSHIFT -> + E.mkUFun ("<<") [|e0;e1|] + | SESP.RSHIFT -> + E.mkUFun (">>") [|e0;e1|] + | SESP.RSHIFTU -> + E.mkUFun (">>u") [|e0;e1|] + | SESP.BINARY -> + (* SI: don't know what ExprBINARY(BINARY,_,_) is *) + failwith "xlate_binary:BINARY" + | SESP.PLUS_OVF | SESP.MINUS_OVF | SESP.MULT_OVF -> + failwith "Overflow arithmetic not supported" + +(** [xlate_expr_lv ... p lv s] returns [p',ea,s'] where [ea] represents the "effective address" that an + assignment [lv = rv] would modify. This can be either a register [Reg], in which case the assignment + should be implemented with [Move], or a memory address [Adr], in which case the assignment should be + implemented with [Store]. The translation also extends command prefix [p] to [p'], which is a list of + commands, in reverse order, to execute to set up the value of [ea]; and command suffix [s] to [s'], which + is a list of commands to be executed after [ea] becomes dead. *) +let rec xlate_expr_lv cfg pos globals locals prefix expr suffix = try + let open Expr in let open SESP in + L.incf 4 "( xlate_expr_lv: %a" fmt_expr_typ expr ; + (fun (prefix, lv, suffix) -> + L.decf 4 ") : (@[%a;@ %a@ %a@])" fmt_blk (List.rev prefix) fmt_lvalue lv fmt_blk suffix ) + <& + match expr.desc with + + | ExprSymb(symb) -> + let ty = type_of_expr expr in + let var = var_of_symb globals locals ty symb in + (prefix, Reg(var), suffix) + + | ExprSymbSlayer(var) -> + (prefix, Reg(var), suffix) + + (* This clause reverts ESP's bogus introduction of & around arrays in l-value position. There are no valid + l-value expressions of form &e, so this non-semantics-preserving translation does not mistranslate valid + code. *) + | ExprAddr(arr) -> + assert( is_array arr.ty ); + xlate_expr_lv cfg pos globals locals prefix arr suffix + + | ExprDeref(ptr) -> + (* Revert ESP's bogus introduction of & around arrays in l-value position. *) + let ptr = match ptr.desc with ExprAddr(arr) when is_array arr.ty -> arr | _ -> ptr in + let prefix, adr, suffix = xlate_expr_rv cfg pos globals locals prefix ptr suffix in + (prefix, Adr(adr), suffix) + + | ExprBinary(INDEX, arr, idx) -> + (* Revert ESP's bogus introduction of & around arrays in l-value position. *) + let arr = match arr.desc with ExprAddr(arr) -> assert( is_array arr.ty ); arr | _ -> arr in + let prefix, ea, suffix = xlate_expr_lv cfg pos globals locals prefix arr suffix in + let arr = match ea with Adr(a) -> a | Reg(v) -> E.mkVar v in + let prefix, idx, suffix = xlate_expr_rv cfg pos globals locals prefix idx suffix in + (prefix, Adr(E.mkIdx arr idx), suffix) + + | ExprDot(pstruct, fld) -> + (match xlate_expr_lv cfg pos globals locals prefix pstruct suffix with + | prefix, Adr(ptr), suffix -> + (prefix, Adr(E.mkAdd ptr (fld_of pstruct.ty fld)), suffix) + | _ -> + failwith "Unexpected stack-allocated struct access" + ) + | ExprConvert(Convert_PTR_UNRELATED, {desc= ExprConvert(_,_)}) -> + (* Not sure yet what to do with nested l-value casts of this form. *) + failwithf "Unexpected l-value pointer cast: %a" fmt_expr expr + + | ExprConvert(conv, l) -> + let r_ty = type_of_esp_type expr.ty in + let l_ty = type_of_esp_type l.ty in + let cfg_symb = Cfg.symb cfg in + let tmp = mk_tmp ~prefix:"lval_cast_tmp" cfg_symb (Var.sort_of_type r_ty) in + (match conv with + | Convert_PTR_UNRELATED -> + (* For pointer casts, the actual semantics of just copying the bit representation coincides with + performing a coercion from a pointer of one type to a pointer of another, so translate the + l-value cast to the corresponding r-value cast. *) + (* xlate (r_ty)l = r where l:l_ty to { r_ty t = r; l = (l_ty)t; } *) + let infix, lv, suffix = xlate_expr_lv cfg pos globals locals [] l suffix in + let suffix = + match lv with + | Reg(v) -> + let cast = I.mk (I.Cast(v, l_ty, E.mkVar tmp)) pos in + (cast :: suffix) + | Adr(a) -> + let tmp2 = mk_tmp ~prefix:"store_cast_tmp" cfg_symb (Var.sort_of_type l_ty) in + let cast = I.mk (I.Cast(tmp2, l_ty, E.mkVar tmp)) pos in + let store = I.mk (I.Store(a, E.mkVar tmp2)) pos in + (cast :: store :: suffix) + in + (prefix, Reg(tmp), List.rev_append infix suffix) + | _ -> + (* For non-pointer casts, the actual semantics of just copying the bit representation cannot be + represented, so translate to non-deterministic assignment. There may be more cases where the + precise semantics can be expressed. *) + let rec unwrap e = + match e.desc with + | ExprConvert(_,e) -> unwrap e + | _ -> e + in + let l = unwrap l in + let infix, lv, suffix = xlate_expr_lv cfg pos globals locals [] l suffix in + let suffix = + match lv with + | Reg(v) -> + mkKill v pos suffix + | Adr _ -> + (* Not sure yet what to do with non-pointer l-value casts of expressions that denote addresses. *) + failwithf "Unexpected l-value non-pointer cast: %a" fmt_expr expr + in + (prefix, Reg(tmp), List.rev_append infix suffix) + ) + | ExprSeq(ee) -> + (* For unused expressions calculate rvalues *) + let rec step prefix ee suffix = + match ee with + | [e] -> + xlate_expr_lv cfg pos globals locals prefix e suffix + | e::ee -> + let prefix,_,suffix = xlate_expr_rv cfg pos globals locals prefix e suffix in + step prefix ee suffix + | [] -> + failwith "Unexpected empty sequence expression" + in + step prefix ee suffix + + | ExprConstString _ -> + let prefix, str, suffix = xlate_expr_rv cfg pos globals locals prefix expr suffix in + (prefix, Adr(str), suffix) + + | _ -> + failwithf "not an lvalue: %a" fmt_expr expr + + with exc -> L.printf 0 "xlate_expr_lv: %a" Expr.fmt_expr expr ; raise exc + + +(** [xlate_expr_rv ... p rv s] returns [p',e,s'] where [e] represents the value that an assignment [lv = rv] + would move/store to [lv]. The translation also extends command prefix [p] to [p'], which is a list of + commands, in reverse order, to execute to set up the value of [e]; and command suffix [s] to [s'], which + is a list of commands to be executed after [e] becomes dead. *) +and xlate_expr_rv cfg pos globals locals prefix expr suffix = try + let open Expr in let open SESP in + L.incf 4 "( xlate_expr_rv: %a" fmt_expr_typ expr ; + (fun (prefix,e,suffix) -> + L.decf 4 ") : (@[%a;@ %a@ %a@])" fmt_blk (List.rev prefix) E.fmt e fmt_blk suffix ) + <& + let cfg_symb = Cfg.symb cfg in + match expr.desc with + + | ExprSymb(symb) -> + let ty = type_of_expr expr in + let var = var_of_symb globals locals ty symb in + (prefix, E.mkVar var, suffix) + + | ExprSymbSlayer(var) -> + (prefix, E.mkVar var, suffix) + + | ExprAddr(ptr) -> + (match xlate_expr_lv cfg pos globals locals prefix ptr suffix with + | prefix, Adr(a), suffix -> + (prefix, a, suffix) + | _ -> + failwith "Unexpected address-of non-l-value expression" + ) + | ExprDeref(ptr) -> + let prefix, adr, suffix = xlate_expr_rv cfg pos globals locals prefix ptr suffix in + let tmp = mk_tmp ~prefix:"load_tmp" cfg_symb (Var.sort_of_type (type_of_expr expr)) in + (mkLoad tmp adr pos :: prefix, E.mkVar tmp, suffix) + + | ExprBinary(INDEX, arr, idx) -> + let prefix, ea, suffix = xlate_expr_lv cfg pos globals locals prefix arr suffix in + let prefix, idx, suffix = xlate_expr_rv cfg pos globals locals prefix idx suffix in + let tmp = mk_tmp ~prefix:"load_tmp" cfg_symb (Var.sort_of_type (type_of_expr expr)) in + let arr = match ea with Adr(a) -> a | Reg(v) -> E.mkVar v in + (mkLoad tmp (E.mkIdx arr idx) pos :: prefix, E.mkVar tmp, suffix) + + | ExprDot _ -> + let prefix, ea, suffix = xlate_expr_lv cfg pos globals locals prefix expr suffix in + (match ea with + | Reg(v) -> + (prefix, E.mkVar v, suffix) + | Adr(a) -> + let tmp = mk_tmp ~prefix:"load_tmp" cfg_symb (Var.sort_of_type (type_of_expr expr)) in + (mkLoad tmp a pos :: prefix, E.mkVar tmp, suffix) + ) + (* CONTAINING_RECORD(address, pstruct_type, field) *) + | ExprConvert(_, {desc= ExprBinary(MINUS, + {desc= ExprConvert(_, address); ty= pchar_ty}, + {desc= ExprConstInt(o)})}) + when is_pchar pchar_ty && Option.is_some (get_struct_of_pstruct expr.ty) -> + let prefix, adr, suffix = xlate_expr_rv cfg pos globals locals prefix address suffix in + let ty = type_of_esp_type (Option.from_some (get_struct_of_pstruct expr.ty)) in + (match Typ.paths_at_offset ty (Int64.to_int o, None) with + | (path,_)::_ -> (prefix, E.mkSubs adr path, suffix) + | [] -> L.printf 0 "No field found at offset %Li of type@ %a" o Typ.fmt ty ; failwith "xlate_expr_rv" + ) + | ExprConstInt(0L) when is_ptr expr.ty -> + (prefix, E.nil, suffix) + + | ExprConstInt(i) -> + (prefix, E.mkNum i, suffix) + + | ExprConstFloat(f) -> + (prefix, E.mkUFun "real_const" [| E.mkUFun (string_of_float f) [||] |], suffix) + + | ExprConstString(_len,str,_wide) -> + (prefix, E.mkStr (String.escaped str), suffix) + + | ExprUplus(e0) -> + xlate_expr_rv cfg pos globals locals prefix e0 suffix + + | ExprNegate(e0) -> + let prefix, e0, suffix = xlate_expr_rv cfg pos globals locals prefix e0 suffix in + (prefix, E.mkZMin e0, suffix) + + | ExprNot(e0) -> + let prefix, e0, suffix = xlate_expr_rv cfg pos globals locals prefix e0 suffix in + (prefix, E.mkNot e0, suffix) + + | ExprBitNot(e0) -> + let prefix, e0, suffix = xlate_expr_rv cfg pos globals locals prefix e0 suffix in + (prefix, E.mkUFun ("~") [|e0|], suffix) + + | ExprCompare(op,e0,e1) -> + let xlate_compare_op op e0 e1 = + match op with + | LT | LTU -> E.mkZLt e0 e1 + | LE | LEU -> E.mkZLe e0 e1 + | GT -> E.mkZGt e0 e1 + | GE -> E.mkZGe e0 e1 + | EQUALS -> E.mkEq e0 e1 + | NE -> E.mkDq e0 e1 in + let prefix, e0, suffix = xlate_expr_rv cfg pos globals locals prefix e0 suffix in + let prefix, e1, suffix = xlate_expr_rv cfg pos globals locals prefix e1 suffix in + let ce = xlate_compare_op op e0 e1 in + (prefix, ce, suffix) + + | ExprBinary(op,e0,e1) -> + let prefix, e0, suffix = xlate_expr_rv cfg pos globals locals prefix e0 suffix in + let prefix, e1, suffix = xlate_expr_rv cfg pos globals locals prefix e1 suffix in + let be = xlate_binary_op op e0 e1 in + (prefix, be, suffix) + + | ExprConvert(_,e0) -> + let prefix, e, suffix = xlate_expr_rv cfg pos globals locals prefix e0 suffix in + let ty = type_of_esp_type expr.ty in + let tmp = mk_tmp ~prefix:"cast_tmp" cfg_symb (Var.sort_of_type ty) in + let cast = I.mk (I.Cast(tmp, ty, e)) pos in + (cast :: prefix, E.mkVar tmp, suffix) + + | ExprAssign(op,lhs,rhs) -> + let prefix, rv, suffix = xlate_expr_rv cfg pos globals locals prefix rhs suffix in + let prefix, ea, suffix = xlate_expr_lv cfg pos globals locals prefix lhs suffix in + (match E.desc rv with + (* vector rv (array init) *) + | E.OpN(E.UFun(f), ee) when f = array_init_func_name -> + (* PS #658: Only catches x = {1;2;3;4;5} case right now, not x = {1}. + We should get the size from the type of [lv]. *) + assert( op = None ); + let _last_idx, prefix = + List.fold_left (fun (idx, prefix) e -> + let base = match ea with Adr(a) -> a | Reg(v) -> E.mkVar v in + let base_idx = E.mkIdx base (E.mkNum idx) in + let c = mkStore base_idx (E.name e) pos in + (Int64.succ idx, c :: prefix) + ) (Int64.zero, prefix) (Array.to_list ee) in + (prefix, rv, suffix) + (* vector rv (struct init) *) + | E.OpN(E.UFun(f),_ee) when f = struct_init_func_name -> + failwith "unimplemented" + (* scalar rv *) + | _ -> + match ea with + | Reg(v) -> + let rv = Option.fold (fun op -> xlate_binary_op op (E.mkVar v)) op rv in + ((mkMove v rv pos) :: prefix, rv, suffix) + | Adr(a) -> + match op with + | None -> + ((mkStore a rv pos) :: prefix, rv, suffix) + | Some op -> + let sort = Var.sort_of_type (type_of_expr lhs) in + let t = mk_tmp ~prefix:"fused_assign_load_tmp" cfg_symb sort in + let rv = xlate_binary_op op (E.mkVar t) rv in + ((mkStore a rv pos) :: (mkLoad t a pos) :: prefix, rv, suffix) + ) + | ExprIncr(op,e,_) -> + let incr exp = + match E.sort_of exp with + | Var.IntegerSort -> E.mkZAdd [|exp; E.one|] + | Var.PointerSort -> E.mkIdx exp E.one + | Var.BooleanSort | Var.OffsetSort -> failwith "cannot increment boolean or offset" + and decr exp = + match E.sort_of exp with + | Var.IntegerSort -> E.mkZSub [|exp; E.one|] + | Var.PointerSort -> E.mkIdx exp (E.mkNum(-1L)) + | Var.BooleanSort | Var.OffsetSort -> failwith "cannot decrement boolean or offset" + in + let prefix, ea, suffix = xlate_expr_lv cfg pos globals locals prefix e suffix in + (match ea with + | Reg(v) -> + let vv = E.mkVar v in + (match op with + | PREINCR -> (mkMove v (incr vv) pos :: prefix, vv, suffix) + | POSTINCR -> (mkMove v (incr vv) pos :: prefix, decr vv, suffix) + | PREDECR -> (mkMove v (decr vv) pos :: prefix, vv, suffix) + | POSTDECR -> (mkMove v (decr vv) pos :: prefix, incr vv, suffix) + ) + | Adr(a) -> + let t = mk_tmp ~prefix:"incr_load_tmp" cfg_symb (Var.sort_of_type (type_of_expr e)) in + let tv = E.mkVar t in + let prefix = mkLoad t a pos :: prefix in + (match op with + | PREINCR -> (mkStore a (incr tv) pos :: prefix, incr tv, suffix) + | POSTINCR -> (mkStore a (incr tv) pos :: prefix, tv, suffix) + | PREDECR -> (mkStore a (decr tv) pos :: prefix, decr tv, suffix) + | POSTDECR -> (mkStore a (decr tv) pos :: prefix, tv, suffix) + ) + ) + | ExprArrayInit(ee) -> + let (prefix, suffix), ee_rev = List.fold_left (fun ((prefix,suffix),ee_rev) e -> + let prefix,e,suffix = xlate_expr_rv cfg pos globals locals prefix e suffix in + ((prefix,suffix), e :: ee_rev) + ) ((prefix,suffix),[]) ee in + let f = array_init_func_name in + let ainit = E.mkUFun f (Array.of_list (List.rev ee_rev)) in + (prefix, ainit, suffix) + + | ExprStructInit(ee) -> + let (prefix, suffix), ee_rev = List.fold_left (fun ((prefix,suffix),ee_rev) e -> + let prefix,e,suffix = xlate_expr_rv cfg pos globals locals prefix e suffix in + ((prefix,suffix), e :: ee_rev) + ) ((prefix,suffix),[]) ee in + let f = struct_init_func_name in + let ainit = E.mkUFun f (Array.of_list (List.rev ee_rev)) in + (prefix, ainit, suffix) + + | ExprSeq ee -> + let rec step prefix ee suffix = + match ee with + | [e] -> + xlate_expr_rv cfg pos globals locals prefix e suffix + | e::ee -> + let prefix,_,suffix = xlate_expr_rv cfg pos globals locals prefix e suffix in + step prefix ee suffix + | [] -> + failwith "Unexpected empty sequence expression" + in + step prefix ee suffix + + with exc -> L.printf 0 "xlate_expr_rv: %a" Expr.fmt_expr expr ; raise exc + + +(*============================================================================ + Translate SESP.node. Set the edges in the graph too. + ============================================================================*) + +module CFG = struct + include CFG + + (* Add u--e--> w to g. *) + let add_edge g u c w = + L.printf 6 "added edge %a -%a-> %a" K.Id.fmt (K.id u) C.fmt c K.Id.fmt (K.id w) ; + add_edge g u c w + + (* Replace v--Nop-->v' by v--blk-->v' in g. *) + let replace_edge g (v,_,v') blk = + L.printf 6 "replace_edge (%a,%a) e:%a" K.fmt v K.fmt v' fmt_blk blk ; + remove_edge g v (mkNop (K.pos v')) v' ; + add_block_edge g v blk v' + +end + + +let xlate_node _cfgs (cfg:SESP.cfg) + vars_to_heap node_to_edge globals locals (g:CFG.graph) + (node:SESP.node) : unit = + + L.incf 3 "( xlate_node: %a " SESPExt.fmt_node node ; + + (* "Constants" *) + let cfg_symb, node_id = SESP.Cfg.symb cfg, SESP.Node.id node in + let pos = xlate_pos (SESP.Node.source_location node) in + + (* xlate_node local functions *) + + (* Add node--blk-->succ in g *) + let connect_to_succ blk succ = + let (_,_,node_tgt) = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb,node_id) in + let succ_id = SESP.Node.id succ in + let (succ_src,_,_) = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb,succ_id) in + CFG.add_block_edge g node_tgt blk succ_src + in + + (* Translate Call's args. *) + let xlate_call_args prefix args suffix = + let prefix, args, suffix = + Array.fold_right (fun arg (prefix, args, suffix) -> + let arg = Expr.expr_of_EspExpr arg in + let ty = type_of_esp_type arg.Expr.ty in + let isStruct = match Typ.desc ty with | Typ.Structure _ -> true | _ -> false in + let arg = if isStruct then Expr.mk_expr (Expr.ExprAddr(arg)) (arg.Expr.ty) else arg in + let arg = Expr.heapify_expr vars_to_heap arg in + let prefix, a, suffix = xlate_expr_rv cfg pos globals locals prefix arg suffix in + (prefix, a :: args, suffix) + ) args (prefix,[],suffix) in + + let prefix, args, suffix = + List.fold_right (fun arg (prefix, args, suffix) -> + match E.desc arg with + (* no tmp needed if arg is a variable and distinct from other args *) + | E.Var(v) when not (List.mem v args) -> + (prefix, v :: args, suffix) + | _ -> + let v = mk_tmp ~prefix:"arg_tmp" cfg_symb (E.sort_of arg) in + (mkMove v arg pos :: prefix, v :: args, suffix) + ) args (prefix,[],suffix) in + + prefix, args, suffix + in + + let areturn_from_CallReturn args node = + match SESP.Node.refine node with + | SESP.CallReturn(Some(ret),_) -> + let ret = Expr.expr_of_EspExpr ret in + (match ret.Expr.desc with + | Expr.ExprSymb(symb) -> + let ty = Expr.type_of_expr ret in + L.printf 8 "Return type: %a" Typ.fmt ty; + (match Typ.desc (Expr.type_of_expr ret) with + | Typ.Structure _ -> + (* Struct returning functions, are translating into taking an extra argument of the struct *) + L.printf 8 "Structure returning function"; + ((var_of_symb globals locals (Typ.mkPointer ty) symb) :: args, None) + | _ -> + (args, Some (var_of_symb globals locals ty symb)) + ) + | _ -> + failwith "return variable expected to be a variable" + ) + | SESP.CallReturn(None,_) -> + (args, None) + | _ -> + failwith "return node of Call expected to be a CallReturn" + in + let get_areturn_from_CallReturn node = + match areturn_from_CallReturn [] node with + | ([], Some(areturn)) -> areturn + | _ -> failwith "No return variable for non-void returning function" + (* Could also be an issue with Struct types, but not reachable from the code *) + in + + (* xlate_node actual translation *) + (match SESP.Node.refine node with + + | SESP.Entry(succ, _pre) -> + connect_to_succ no_insts succ + + | SESP.Exit(_post) -> + () + + | SESP.ExceptionExit -> + L.printf 8 "Ignoring ExceptionExit" + | SESP.Pattern _ -> + failwith "xlate_node: espCU doesn't implemented SESP.Pattern either" + | SESP.Event -> + failwith "xlate_node: espCU doesn't implement SESP.Event either" + + | SESP.Call(SESP.Direct(f), [|size|], callreturn,_,_,_) when symb_name f = "_SLAyer_malloc" -> + let areturn = get_areturn_from_CallReturn callreturn in + let size = Expr.expr_of_EspExpr size in + let size = Expr.heapify_expr vars_to_heap size in + let prefix, size, suffix = xlate_expr_rv cfg pos globals locals [] size [] in + let prefix_alloc_suffix = List.rev_append (I.mk (I.Alloc(areturn, size)) pos :: prefix) suffix in + let nedge = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, node_id) in + CFG.replace_edge g nedge prefix_alloc_suffix ; + connect_to_succ no_insts callreturn + + | SESP.Call(SESP.Direct(f), [|ptr|], callreturn,_,_,_) when symb_name f = "_SLAyer_free" -> + let ptr = Expr.expr_of_EspExpr ptr in + let ptr = Expr.heapify_expr vars_to_heap ptr in + let prefix, ptr, suffix = xlate_expr_rv cfg pos globals locals [] ptr [] in + let prefix_free_suffix = List.rev_append (I.mk (I.Free(ptr)) pos :: prefix) suffix in + let nedge = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, node_id) in + CFG.replace_edge g nedge prefix_free_suffix ; + connect_to_succ no_insts callreturn + + | SESP.Call(SESP.Direct(f), [||],_,_,_,_) when symb_name f = "_SLAyer_error" -> + let nedge = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, node_id) in + CFG.replace_edge g nedge [I.mk (I.Assert(E.ff)) pos] + + | SESP.Call(SESP.Direct(f), [||],_,_,_,_) when symb_name f = "_SLAyer_unreachable" -> + let nedge = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, node_id) in + CFG.replace_edge g nedge [I.mk (I.Assume(E.ff)) pos] + + | SESP.Call(SESP.Direct(f), [||], callreturn,_,_,_) when symb_name f = "_SLAyer_nondet" -> + let areturn = get_areturn_from_CallReturn callreturn in + let kill = I.mk (I.Kill(Vars.singleton areturn)) pos in + let nedge = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, node_id) in + CFG.replace_edge g nedge [kill] ; + connect_to_succ no_insts callreturn + + | SESP.Call(call_target, actuals, callreturn,_,_,_) -> + let xlate_actuals prefix suffix = + let prefix, actuals, suffix = xlate_call_args prefix actuals suffix in + (prefix, areturn_from_CallReturn actuals callreturn, suffix) + in + let prefix, call, suffix = + match call_target with + | SESP.Direct(f) -> + let proc = proc_of f in + let typ = type_of_esp_type (SESP.Symb.ctype f) in + let prefix, (actuals, areturn), suffix = xlate_actuals [] [] in + (prefix, C.Call{Call.proc; actuals; areturn; typ; targets= [proc]}, suffix) + | SESP.Indirect(fp) -> + let fp = Expr.expr_of_EspExpr fp in + let fp = Expr.heapify_expr vars_to_heap fp in + let fp = + match fp.Expr.desc with + | Expr.ExprDeref(f) -> f + | _ -> failwith "Got ICall(pf), not ICall(*pf)" in + let prefix, proc, suffix = xlate_expr_rv cfg pos globals locals [] fp [] in + let typ = Expr.type_of_expr fp in + let prefix, (actuals, areturn), suffix = xlate_actuals prefix suffix in + (prefix, C.ICall{Call.proc; actuals; areturn; typ; targets= []}, suffix) + | _ -> + failwith "C++ Calls unimplemented" + in + (* Replace the node_src-->node_trg edge with: *) + (* (node_src)--prefix-->(pre_call)--call--(pre_kill)--suffix-->(node_trg) *) + let node_src, node_lbl, node_trg = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, node_id) in + assert( C.equal node_lbl (mkNop (K.pos node_trg)) ); + let pre_call_vtx = CFG.add_vertex g (K.mk_label pos (K.proc node_src)) in + let pre_kill_vtx = CFG.add_vertex g (K.mk_label pos (K.proc node_trg)) in + CFG.remove_edge g node_src node_lbl node_trg ; + CFG.add_block_edge g node_src (List.rev prefix) pre_call_vtx ; + CFG.add_edge g pre_call_vtx call pre_kill_vtx ; + CFG.add_block_edge g pre_kill_vtx suffix node_trg ; + connect_to_succ no_insts callreturn + + | SESP.CallReturn(_, succo) -> + Option.iter (fun succ -> connect_to_succ no_insts succ) succo + + | SESP.Return(ret, succ) -> + (* This code converts returns into assignments. This requires + Returns to be findable, as they are always followed by an Exit.*) + assert( match SESP.Node.refine succ with SESP.Exit _ -> true | _ -> false ); + let freturn = + match SESP.Cfg.formal_return cfg with + | Some(symb) -> symb + | None -> + failwithf "Unexpected return from procedure %a without a return variable" SESPExt.fmt_symb cfg_symb in + let fty = SESP.Expr.ctype ret in + let assign = Expr.mk_expr_assign None (Expr.mk_expr (Expr.ExprSymb(freturn)) fty) (Expr.expr_of_EspExpr ret) in + let assign = Expr.heapify_expr vars_to_heap assign in + let prefix, _assign_val, suffix = xlate_expr_rv cfg pos globals locals [] assign [] in + + let nsrc, nlbl, ntrg = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, node_id) in + assert( C.equal nlbl (mkNop (K.pos ntrg)) ); + CFG.replace_edge g (nsrc,nlbl,ntrg) (List.rev_append prefix suffix); + connect_to_succ no_insts succ + + | SESP.CallUnwind(succo) -> + L.printf 8 "ignoring CallUnwind" ; + (* But still hooking up to node to [succ] *) + (match succo with + | Some succ -> connect_to_succ no_insts succ + | None -> ()) + | SESP.Decl(_symb, _ty, succ) -> + L.printf 8 "ignoring Decl" ; + (* But still hooking up to node to [succ] *) + connect_to_succ no_insts succ + + | SESP.StaticDeclBegin(_symb, _ty, succ) -> + L.printf 8 "ignoring StaticDeclBegin" ; + (* But still hooking up to node to [succ] *) + connect_to_succ no_insts succ + + | SESP.StaticDeclEnd(succ) -> + L.printf 8 "ignoring StaticDeclEnd" ; + (* But still hooking up to node to [succ] *) + connect_to_succ no_insts succ + + | SESP.Endscope -> + failwith "xlate_node: espCU doesn't implement SESP.Endscope either" + + | SESP.Throw(succ) -> + L.printf 8 "Ignoring Throw" ; + connect_to_succ no_insts succ + + | SESP.RaiseException -> + failwith "xlate_node: espCU doesn't implement SESP.RaiseException either" + | SESP.CatchBegin(succ) -> + L.printf 8 "Ignoring CatchBegin" ; + connect_to_succ no_insts succ + | SESP.CatchEnd(succ) -> + L.printf 8 "Ignoring CatchEnd" ; + connect_to_succ no_insts succ + + | SESP.Branch(cond, nelse, nthen) -> + + let cond = Expr.expr_of_EspExpr cond in + let cond = Expr.heapify_expr vars_to_heap cond in + + let prefix, ce, suffix = xlate_expr_rv cfg pos globals locals [] cond [] in + let ce = Option.from_some (E.convert Var.BooleanSort ce) in + let not_ce = E.mkNot ce in + + (* Replace current edge label with [cond_insts] *) + let nedge = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb,node_id) in + CFG.replace_edge g nedge (List.rev prefix) ; + + let connect desc node = + connect_to_succ (I.mk desc pos :: suffix) node + in + let connect_assert_assume desc node = + let open! SESP in + match Node.refine node with + | Expression(Some(assign_pred_one), Some(nsucc)) -> + assert( (* sanity check expression is as expected *) + match Expr.refine assign_pred_one with + | ExprASSIGN(ASSIGN,(pred,one)) -> + (match Expr.refine pred with + | ExprLEAF(SYMBOL(symb)) -> Str.string_match (Str.regexp "#Pred\\.[^#]+#.*") (Symb.name symb) 0 + | _ -> false) && + (match Expr.refine one with + | ExprLEAF(CONSTANT(1L)) -> true + | _ -> false) + | _ -> false + ); + connect desc nsucc + | _ -> + connect desc node + in + (match SESP.Node.refine nelse with + | SESP.Call(SESP.Direct(f),[||],_,_,_,_) when symb_name f = "_SLAyer_error" -> + connect_assert_assume (I.Assert(ce)) nthen + + | SESP.Call(SESP.Direct(f),[||],_,_,_,_) when symb_name f = "_SLAyer_unreachable" -> + connect_assert_assume (I.Assume(ce)) nthen + + | _ -> + match SESP.Node.refine nthen with + | SESP.Call(SESP.Direct(f),[||],_,_,_,_) when symb_name f = "_SLAyer_error" -> + connect_assert_assume (I.Assert(not_ce)) nelse + + | SESP.Call(SESP.Direct(f),[||],_,_,_,_) when symb_name f = "_SLAyer_unreachable" -> + connect_assert_assume (I.Assume(not_ce)) nelse + + | _ -> + connect (I.Assume(ce)) nthen ; + connect (I.Assume(not_ce)) nelse + ) + + | SESP.Switch(test, label_bodys, default) -> + + let test = Expr.expr_of_EspExpr test in + let test = Expr.heapify_expr vars_to_heap test in + + let prefix, te, suffix = xlate_expr_rv cfg pos globals locals [] test [] in + let te = Option.from_some (E.convert Var.IntegerSort te) in + + (* Replace current edge label with [test]'s [prefix] *) + let nedge = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb,node_id) in + CFG.replace_edge g nedge (List.rev prefix) ; + + (* label: body *) + let (lbl_prefixes,lbl_es,lbl_suffixes) = + List.fold_left (fun (pp,ee,ss) (label,body) -> + let label = Expr.expr_of_EspExpr label in + let label = Expr.heapify_expr vars_to_heap label in + + let lprefix, le, lsuffix = xlate_expr_rv cfg pos globals locals [] label [] in + let le = Option.from_some (E.convert Var.IntegerSort le) in + + let assumption = I.mk (I.Assume(E.mkEq te le)) pos in + let insts = prefix @ [assumption] @ lsuffix @ suffix in + + (* Connect node_tgt to src(body) *) + connect_to_succ insts body ; + + (* And also keep all (lprefix,le,lsuffix)s for the default case. *) + (lprefix::pp, le :: ee, lsuffix :: ss) + + ) ([],[],[]) (Array.to_list label_bodys) in + + (* default *) + let assumption = E.mkAnd + (Array.of_list (List.map (fun lbl -> E.mkNot (E.mkEq te lbl)) lbl_es)) in + let insts = + List.concat lbl_prefixes @ + [(I.mk (I.Assume(assumption)) pos)] @ + List.concat lbl_suffixes @ + suffix in + connect_to_succ insts default + + | SESP.Expression (ceo, succo) -> + let (nsrc,nlbl,ntrg) = SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb,node_id) in + (match ceo with + | Some ce -> + (* SI: xlate_expr_rv might do the replace_edge itself. See Note (1) + in the function. *) + let ce = Expr.expr_of_EspExpr ce in + let ce = Expr.heapify_expr vars_to_heap ce in + let ce_insts, _ce_e, suffix = xlate_expr_rv cfg pos globals locals [] ce [] in + (* SI: Replace current edge label with [ce_insts]. + Ignore [ce_e] in this expr-statement context? *) + CFG.replace_edge g (nsrc,nlbl,ntrg) (List.rev_append ce_insts suffix) + | None -> () + ) ; + Option.iter (fun succ -> connect_to_succ no_insts succ) succo + + (* SI: eSPCU doesn't expect Assume and Verify? *) + | SESP.Assume(succ, _assumes) -> + L.printf 8 "Ignoring Assume" ; + connect_to_succ no_insts succ + | SESP.Verify(succ, _verify) -> + L.printf 8 "Ignoring Verify" ; + connect_to_succ no_insts succ + + | SESP.Asm(succ) -> + L.printf 8 "Ignoring Asm" ; + connect_to_succ no_insts succ + + | SESP.Nop(succ) -> + connect_to_succ no_insts succ + ); + L.decf 3 ") xlate_node" + + +(*============================================================================ + In the initial stage of the translation, each esp node is mapped to + a Program.CFG edge. We set up the edge here, with a dummy edge label + (expecting xlate_node to over-write it). + ============================================================================*) + +let edge_of_node proc graph node = + + let pos = xlate_pos (SESP.Node.source_location node) in + + let vtx_src = CFG.add_vertex graph (K.mk_label pos proc) in + + let vtx_tgt = CFG.add_vertex graph (K.mk_label pos proc) in + + CFG.add_edge graph vtx_src (mkNop pos) vtx_tgt ; + + (vtx_src, mkNop pos, vtx_tgt) + + +(*============================================================================ + Convert esp cfg into Graph_sig representation. + ============================================================================*) + +(* Very light modules, don't need more at this point. *) +module NodeId = struct + type t = int + let compare = Pervasives.compare + let equal x y = (x=y) + let hash = Hashtbl.hash + let fmt = Format.pp_print_int +end +module NodeStr = struct + type t = string + let compare = Pervasives.compare + let equal x y = (x=y) + let fmt = Format.pp_print_string +end +module NullEdge = struct + type t = unit + let compare = Pervasives.compare + let equal x y = (x=y) + let fmt ff () = Format.pp_print_string ff "" +end + +module ESPGraph = Graph.Make(NodeId)(NodeStr)(NullEdge) + +let graph_of_esp_cfg _filename cfg = + + let nodes = SESP.Cfg.nodes cfg in + let cfg_symb = SESP.Cfg.symb cfg in + + let g = ESPGraph.create () in + let node_to_vtx : ESPGraph.Vertex.t SESPExt.CfgNodeHMap.t = + SESPExt.CfgNodeHMap.create (Array.length nodes) in + + (* Add all the vertices *) + Array.iter (fun n -> + let id = SESP.Node.id n in + let s = Format.asprintf "%a" SESPExt.fmt_node n in + let v = ESPGraph.add_vertex g (id, s) in + SESPExt.CfgNodeHMap.add node_to_vtx (cfg_symb,id) v + ) nodes ; + (* Add all the edges *) + Array.iter (fun n -> + let id = SESP.Node.id n in + let sso = SESP.Node.succs_optional n in + Array.iter (fun so -> + match so with + | Some s -> + let s_id = SESP.Node.id s in + let v_n = SESPExt.CfgNodeHMap.find node_to_vtx (cfg_symb,id) in + let v_s = SESPExt.CfgNodeHMap.find node_to_vtx (cfg_symb,s_id) in + ESPGraph.add_edge g v_n () v_s + | None -> ()) sso + ) nodes ; + + + let entry = SESP.Node.id (SESP.Cfg.entry cfg) in + let entry_vtx = SESPExt.CfgNodeHMap.find node_to_vtx (cfg_symb,entry) in + + (g,entry_vtx) + + + +(*=========================================================================== + Translate a cfg to a proc + ===========================================================================*) + +let proc_of_cfg cfgs globals heapified_globals (cfg:SESP.cfg) : Proc.t = try + + L.incf 3 "( proc_of_cfg: %s" (SESP.Symb.name (SESP.Cfg.symb cfg)) ; (fun _ -> L.decf 3 ") proc_of_cfg: done") <& + + let cfg_symb = SESP.Cfg.symb cfg in + let id = proc_of cfg_symb in + let fty = type_of_esp_type (SESP.Symb.ctype cfg_symb) in + + (* Heapification *) + let vars_to_heap = SESPExt.to_heapify heapified_globals cfg in + L.printf 3 "Heapify {%a}" + (List.fmt "," SESPExt.fmt_symb) (SESPExt.SymbHMap.fold (fun symb _tag symbs -> symb :: symbs) vars_to_heap []) ; + + (* Local variables used in this proc *) + let locals : (Var.t * var_kind * Typ.t) SESPExt.SymbHMap.t = + SESPExt.SymbHMap.create 255 in + + (* Translate the nodes to a cfg graph. *) + let nodes = SESP.Cfg.nodes cfg in + let graph = CFG.create () in + + (* I. Initialize the edge the node will be translated to. *) + let node_to_edge : (CFG.Vertex.t * CFG.e_label * CFG.Vertex.t) + SESPExt.CfgNodeHMap.t = SESPExt.CfgNodeHMap.create (Array.length nodes) in + + Array.iter (fun node -> + let node_id = SESP.Node.id node in + let edge = edge_of_node id graph node in + SESPExt.CfgNodeHMap.add node_to_edge (cfg_symb,node_id) edge + ) nodes ; + + (* II. Translate, and connect the node to the rest of the graph. *) + Array.iter (fun n -> + xlate_node cfgs cfg vars_to_heap node_to_edge globals locals graph n + ) nodes ; + + (* Find entry and exit points. *) + let entry_vtx,_,_ = + let entry_node = SESP.Node.id (SESP.Cfg.entry cfg) in + SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb,entry_node) in + + (* ToDo: ESP's cfg.h includes GetExit which should be exposed as e.g. SESP.Cfg.exit *) + let _,_,exit_vtx = + match + Array.fold_right (fun node exits -> + match SESP.Node.refine node with + | SESP.Exit _ -> node :: exits + | _ -> exits + ) nodes [] + with + | [exit_node] -> SESPExt.CfgNodeHMap.find node_to_edge (cfg_symb, SESP.Node.id exit_node) + | _ -> failwith "expected single exit node" in + + (* Malloc and free local heapified vars *) + let heap_vars = + SESPExt.SymbHMap.fold (fun hsymb htag vars -> + match htag with + | SESPExt.HAddrOfLocal | SESPExt.HLocalStruct -> + let ty = type_of_esp_type (SESP.Symb.ctype hsymb) in + let v = var_of_symb globals locals (SESPExt.heapify_type ty) hsymb in + (v,ty) :: vars + (* Ignore globals, they'll be malloced in main. *) + | SESPExt.HGlobal + | SESPExt.HAddrOfFunc + | SESPExt.HFormal + | SESPExt.HFormalStruct -> vars + ) vars_to_heap [] in + + (* Translate formals *) + let (formals, varargs) = SESP.Cfg.formals cfg in + if varargs then L.printf 1 "Ignoring varags." ; + + let formals = Array.to_list formals in + let formals, heap_vars, assigns = + List.fold (fun f (formals, heap_vars, assigns) -> + let espty = SESP.Symb.ctype f in + let ty = type_of_esp_type espty in + match SESPExt.SymbHMap.tryfind vars_to_heap f with + | Some(SESPExt.HFormal) -> + let v = var_of_symb globals locals (SESPExt.heapify_type ty) f in + let newv = Var.gensym (Var.name v) (Var.sort_of_type ty) in + let mv = I.mk (I.Store(E.mkVar v, E.mkVar newv)) (K.pos entry_vtx) in + (newv :: formals, (v,ty) :: heap_vars, mv :: assigns) + | Some(SESPExt.HFormalStruct) -> + let hty = (SESPExt.heapify_type ty) in + let v = var_of_symb globals locals hty f in + let newv = Var.gensym (Var.name v) (Var.sort_of_type hty) in + let lhs = Expr.mk_expr (Expr.ExprSymb f) espty in + let rhs = Expr.mk_expr (Expr.ExprSymbSlayer newv) espty in + let rhs = Expr.mk_expr (Expr.ExprDeref rhs) espty in + let assign = Expr.mk_expr_assign None lhs rhs in + let assign = Expr.heapify_expr vars_to_heap assign in + let prefix, _, suffix = xlate_expr_rv cfg (K.pos entry_vtx) globals locals [] assign assigns in + (newv :: formals, (v,ty) :: heap_vars, List.rev_append prefix suffix) + | Some _ -> + failwith "Unreachable" + | None -> + let v = var_of_symb globals locals ty f in + (v :: formals, heap_vars, assigns) + ) formals ([], heap_vars, []) in + + let formals = List.rev formals in + L.printf 4 "formals: [%a]" (List.fmt "," (fun ff f -> Var.fmt ff f)) formals ; + + (* Deal with special case, where return type is a struct type *) + let freturn, formals = + match SESP.Cfg.formal_return cfg with + | None -> + (None, formals) + | Some symb -> + let ty = type_of_esp_type (SESP.Symb.ctype symb) in + match Typ.desc ty with + | Typ.Structure _ -> (None, (var_of_symb globals locals (Typ.mkPointer ty) symb) :: formals) + | _ -> (Some(var_of_symb globals locals ty symb), formals) + in + + let malloc_heap_vars = + List.fold_left (fun mm (v,t) -> + (mkAlloc (K.pos entry_vtx) v t) @ mm + ) assigns heap_vars + in + let entry = CFG.add_vertex graph (K.mk_label (K.pos entry_vtx) id) in + CFG.add_block_edge graph entry malloc_heap_vars entry_vtx ; + + let free_heap_vars = + List.fold_left (fun ff (v,_t) -> + mkFree (K.pos exit_vtx) v :: ff + ) [] heap_vars + in + let exit = CFG.add_vertex graph (K.mk_label (K.pos exit_vtx) id) in + CFG.add_block_edge graph exit_vtx free_heap_vars exit ; + + {Proc. + id; + fty; + formals; + freturn; + locals= Vars.empty; + modifs= Vars.empty; + accessed= Vars.empty; + cfg= graph; + entry; + exit; + } + + with exc -> L.printf 0 "proc_of_cfg: %s" (SESP.Symb.name (SESP.Cfg.symb cfg)) ; raise exc + + +(*=========================================================================== + Find constants in prog. + ===========================================================================*) +let prog_consts (main,non_mains) addr_taken_procs = + + let consts : unit Int64HMap.t = Int64HMap.create 31 in + + let num_in_e e = + E.fold (fun e () -> + match E.desc e with + | E.Num(n) -> Int64HMap.add consts n () + | _ -> () + ) e () in + + let num_in_inst {I.desc} = + match desc with + | I.Load(_,e) + | I.Alloc(_,e) | I.Free(e) + | I.Move(_,e) + | I.Cast(_,_,e) + | I.Assume(e) | I.Assert(e) -> num_in_e e + | I.Store(e,e') -> (num_in_e e) ; (num_in_e e') + | I.Kill(_) + | I.Nop -> () + | I.Generic(_) -> failwith "consts_in_generic unimplemented" in + + (* Add ids of the &p's. *) + List.iter (fun p -> + Int64HMap.add consts (Int64.of_int (Proc.Id.id p)) () + ) addr_taken_procs ; + + (* Add const ints in cfg *) + let f _name p = + CFG.iter_edges (fun _v -> ()) (fun (_,c,_) -> + match c with + | C.Inst(i) -> num_in_inst i + | C.Call _ + | C.ICall _ -> () + ) p.Proc.cfg (K.id p.Proc.entry) in + + f () main ; Proc.IdHMap.iter f non_mains ; + + (* Return [consts] keys as a list *) + let ll = Int64HMap.fold (fun k _v ll -> k :: ll) consts [] in + ll + + + + + + + +(*=========================================================================== + Translate cfgs + ===========================================================================*) + +let remove_dead_cfgs cfgs0 = + let open! SESP in + let scan_symb symb todo = + if Symb.kind symb = ESP.ESP_IR_SK_FUNCTION then + (Symb.name symb) :: todo + else + todo + in + let cfgs = StringHMap.create 128 + in + let rec loop = function + | name :: todo -> + if not (StringHMap.mem cfgs name) then + match StringHMap.tryfind cfgs0 name with + | Some(cfg) -> + StringHMap.add cfgs name cfg ; + loop (SESPExt.fold_cfg scan_symb (fun _ todo -> todo) (fun _ todo -> todo) cfg todo) + | None -> + loop todo + else + loop todo + | [] -> + cfgs + in + let todo = + StringHMap.fold (fun name cfg todo -> + let undecoratedname = Symb.undecoratedname (Cfg.symb cfg) in + if (SESPExt.proc_is_agg_static_init undecoratedname || + SESPExt.proc_is_agg_dyn_init undecoratedname) + then + name :: todo + else + todo + ) cfgs0 ["main"] in + loop todo + + +let program_of_cfgs cfgs = + + L.incf 2 "( program_of_cfgs" ; (fun _ -> L.decf 2 ") program_of_cfgs") <& let()=()in + + (* Input cfg graphs, for debugging. *) + if Config.write_cl_cfg then ( + StringHMap.iter (fun _ cfg -> + let cfg_name = SESP.Cfg.name cfg in + let filename = + match SESP.Node.source_location (SESP.Cfg.entry cfg) with + | Some(filename,_) -> Filename.basename filename + | None -> Config.testname in + let cfg_graph,cfg_entry = graph_of_esp_cfg filename cfg in + Library.with_out (filename ^ "." ^ cfg_name ^ ".esp.cfg.dot") + (ESPGraph.write_dot cfg_graph (ESPGraph.index_of cfg_entry)) + ) cfgs + ); + + let cfgs = remove_dead_cfgs cfgs in + + (* SI: check, I don't think I need the Type.t anymore. *) + let globals : (Var.t * var_kind * Typ.t) SESPExt.SymbHMap.t = + SESPExt.SymbHMap.create 255 in + + let procs = Proc.IdHMap.create (StringHMap.length cfgs - 1) in + + (* Heapification: + Have to calculate heapified globals for all procedures, as address taken + globals need boxing, this needs complete knowledge to + calculate. *) + let which_globals = + if Config.optimize_boxing then + fun sym -> SESPExt.to_heapify_type (SESP.Symb.ctype sym) + else + fun _ -> true + in + let vars_to_heap = SESPExt.to_heapify_cfgs which_globals cfgs in + L.printf 3 "Heapify {%a}" (List.fmt "," SESPExt.fmt_symb) + (SESPExt.SymbHMap.fold (fun symb _tag symbs -> symb :: symbs) vars_to_heap []) ; + + let heapified_globals = SESPExt.SymbHMap.mem vars_to_heap in + + let mains = + StringHMap.fold (fun _ cfg mains -> + let open Proc in + let p = proc_of_cfg cfgs globals heapified_globals cfg in + IdHMap.add procs p.id p ; + if Id.name p.id = "main" + then p :: mains + else mains + ) cfgs [] in + + let main = + match mains with + | [main] -> main + | _ -> failwith "Not the one main" + in + + let {Proc.entry= entry_vtx; exit= exit_vtx; formals; freturn} = main in + + (* Malloc and free global heapified vars *) + let heap_vars = + SESPExt.SymbHMap.fold (fun hsymb htag vars -> + match htag with + | SESPExt.HAddrOfLocal | SESPExt.HLocalStruct -> vars + (* Ignore globals, they'll be malloced in main. *) + | SESPExt.HGlobal + | SESPExt.HAddrOfFunc -> (hsymb, SESPExt.SymbHMap.find globals hsymb) :: vars + | SESPExt.HFormal | SESPExt.HFormalStruct -> vars + ) vars_to_heap [] in + + (* Create procedure to allocate and deallocte the globals *) + let mk_proc name pos insts = + let id = Proc.Id.gensym name in + let cfg = CFG.create() in + let entry = CFG.add_vertex cfg (K.mk_label pos id) in + let exit = CFG.add_vertex cfg (K.mk_label pos id) + in + CFG.add_block_edge cfg entry insts exit ; + let p = + {Proc. + id; fty= Typ.mkFunction Typ.mkTop [] false; formals= []; freturn= None; + locals= Vars.empty; modifs= Vars.empty; accessed= Vars.empty; + cfg; entry; exit; + } in + Proc.IdHMap.add procs id p ; + p in + + L.incf 6 "Create alloc and init procedure" ; (* Malloc and free global heapified vars *) + let malloc_heap_vars = + List.fold (fun (symb, (v,tag,_ty)) mm -> + match tag with + | VarKFun -> + let pos = (K.pos entry_vtx) in + let a = mkAlloc pos v (Typ.mkInt false 1) in + let proc_id = Int64.of_int (Proc.Id.id (proc_of symb)) in + let i = mkStore (E.mkVar v) (E.mkNum proc_id) pos in + a @ [i] @ mm + | _ -> + let ty = type_of_esp_type (SESP.Symb.ctype symb) in + (mkAlloc (K.pos entry_vtx) v ty) @ mm + ) heap_vars [] + in + let global_alloc = mk_proc "SLAyer_alloc_and_init_globals" (K.pos entry_vtx) malloc_heap_vars in + + let mkIdCall ({Proc.id} as proc) actuals areturn = + C.Call({(Call.mk proc actuals areturn) with Call.proc= id}) + in + + (* Call aggregate_*_init. *) + let call_inits, init_ids = + Proc.IdHMap.fold (fun _ p (calls, ids) -> + let open Proc in + let name = Id.name p.id in + if (SESPExt.proc_is_agg_static_init name || + SESPExt.proc_is_agg_dyn_init name) + then + (mkIdCall p [] None :: calls, p.id :: ids) + else + (calls, ids) + ) procs ([],[]) in + + let {Proc.exit= ga_exit; cfg= ga_cfg; id= ga_id} = global_alloc in + + let add_call_after cfg id pos call prev_vtx = + let return_vtx = CFG.add_vertex cfg (K.mk_label pos id) in + CFG.add_edge cfg prev_vtx call return_vtx ; + return_vtx (* is next prev_vtx *) in + + (* Add the static and dynamic initialises to the end of the alloc + and init procedure *) + let ga_last = + let graph = ga_cfg in + List.fold (add_call_after graph ga_id (K.pos entry_vtx)) + call_inits ga_exit in + (* Add new exit node, as ga_last with be Return, so need a nop to Exit *) + let ga_exit = CFG.add_vertex ga_cfg (K.mk_label (K.pos entry_vtx) ga_id) in + CFG.add_edge ga_cfg ga_last (mkNop (K.pos entry_vtx)) ga_exit ; + + (* Update the exit for the procedure *) + let global_alloc = {global_alloc with Proc.exit= ga_exit} in + Proc.IdHMap.add procs ga_id global_alloc ; + L.decf 6 "" ; + + L.incf 6 "Create dealloc procedure" ; + (* Deallocate all the globals. *) + let free_heap_vars = + List.fold (fun (_symb, (v,_tag,_ty)) ff -> + mkFree (K.pos exit_vtx) v :: ff + ) heap_vars [] + in + let global_dealloc = mk_proc "SLAyer_dealloc_globals" (K.pos exit_vtx) free_heap_vars in + L.decf 6 "" ; + + let global_setup = [global_alloc.Proc.id; global_dealloc.Proc.id] in + + L.incf 6 "Creating SLAyer main" ; + let slayer_main = mk_proc "SLAyer_main" (K.pos entry_vtx) [] in + let sm_cfg = slayer_main.Proc.cfg in + let sm_id = slayer_main.Proc.id in + let slayer_exit = slayer_main.Proc.exit in + let slayer_last = + List.fold (fun call vtx -> + add_call_after sm_cfg sm_id (K.pos entry_vtx) call vtx + ) [ mkIdCall global_alloc [] None + ; mkIdCall main formals freturn + ; mkIdCall global_dealloc [] None + ] + slayer_exit + in + + let slayer_exit = CFG.add_vertex sm_cfg (K.mk_label (K.pos exit_vtx) sm_id) in + CFG.add_edge sm_cfg slayer_last (mkNop (K.pos entry_vtx)) slayer_exit ; + + L.decf 6 "" ; + + (* Calculate other (meta-data) Prog components *) + (* -- constants *) + let addr_taken = + SESPExt.SymbHMap.fold (fun symb (_v,tag,_ty) pp -> + match tag with + | VarKFun -> proc_of symb :: pp + | _ -> pp + ) globals [] in + let constants = prog_consts (main,procs) addr_taken in + + (* -- globals *) + let addr_taken_vars = + SESPExt.SymbHMap.fold (fun _symb (v,tag,_ty) vv -> match tag with + | VarKFun -> Vars.add v vv + | _ -> vv + ) globals Vars.empty in + let globals = SESPExt.SymbHMap.fold (fun _ (v,tag,_) gs -> match tag with + | VarKFun -> gs + | _ -> Vars.add v gs + ) globals addr_taken_vars in + + Proc.IdHMap.add procs sm_id {slayer_main with Proc.exit= slayer_exit; formals} ; + + {Prog. + constants; + globals; + addr_taken; + main= sm_id; + procs; + global_setup; + inits = init_ids; + } + + +(*============================================================================ + C compiler + ============================================================================*) + +let run_cl filenames = + Unix.putenv "Esp.CfgPersist.ExpandLocalStaticInitializer" "1" ; + + let cl_exe = "cl" in + let args = + Array.of_list ( + [cl_exe] + @ ["/nologo"] + @ ["/DSLAyer=1"] + @ ["/FIslayer_intrinsics.h"] + @ (if Config.no_builtins then [] else ["/FIslayer.h"]) + @ ["/analyze:quiet"] + @ ["/analyze:only"] + @ ["/analyze:plugin"; "ESPPersist.dll"] + @ Config.frontend_args + @ filenames + ) in + L.printf 1 "%s@." (String.concat " " (Array.to_list args)) ; + Pervasives.flush_all () ; + let pid = Unix.create_process cl_exe args Unix.stdin Unix.stdout Unix.stderr in + let _, status = Unix.waitpid [] pid in + if status <> Unix.WEXITED(0) then -1 else 0 + + +(*============================================================================ + Entry point + ============================================================================*) + +let program_of_file filenames = + let cfgs = StringHMap.create 128 + in + let c_files, cfg_files = + List.partition (fun filename -> + if (Filename.check_suffix filename ".c" || Filename.check_suffix filename ".cpp") then + true + else if (Filename.check_suffix filename ".rawcfgf") then + false + else + failwith "input file must be either C source (.c) or an esp cfg (.rawcfgf)" + ) filenames + in + (* run cl to generate .rawcfgf from .c *) + let cl_status = run_cl c_files + in + let cfg_files = + if cl_status = 0 then + List.fold (fun c_file cfg_files -> (c_file ^ ".rawcfgf") :: cfg_files) c_files cfg_files + else + failwith "cl died" + in + List.iter (fun cfg_file -> + Array.iter (fun cfg -> + StringHMap.add cfgs (SESP.Cfg.name cfg) cfg + ) (SESP.Cfgs.cfgs cfg_file) + ) cfg_files + ; + program_of_cfgs cfgs diff --git a/src/frontend_esp.mli b/src/frontend_esp.mli new file mode 100644 index 0000000..230e560 --- /dev/null +++ b/src/frontend_esp.mli @@ -0,0 +1,8 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** ESP->SLAyer translator *) + +open Program + + +val program_of_file : string list -> Prog.t diff --git a/src/slayer.ml b/src/slayer.ml new file mode 100644 index 0000000..a8fa4ab --- /dev/null +++ b/src/slayer.ml @@ -0,0 +1,199 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +(** Main routine of analyzer *) + +open Library + +open Program +module K = ControlPoint + + +type safety_result_t = + | Safe + | PossiblyUnsafe + | Unsafe + +type general_results = { + (* ID *) + tool_version: string; + (* exn *) + internal_error: exn option; (* if Some, then exn field is valid. If None, then the other fields are valid. *) + (* results *) + safety_proved: bool; unsafety_proved: bool; + termination_proved: bool; nontermination_proved: bool; + leaks: bool; + hit_limit: bool; + (* run time *) + time_total: float; + time_preanalysis: float; time_analysis: float; time_postanalysis: float; + time_1: float; time_2: float; time_3: float; (* arbitrary *) +} + + +let success = + { tool_version= Version.version; + internal_error= None; + safety_proved= false; unsafety_proved= false; + termination_proved= false; nontermination_proved= false; + leaks= false; + hit_limit= false; + time_total= -0.; time_preanalysis= -0.; time_analysis= -0.; time_postanalysis= -0.; + time_1= -0.; time_2= -0.; time_3= -0.; + } + + +let str_of_general_results_old r = + match r.internal_error with + | Some(exn) -> + "\nRESULT: Internal Error: "^(Printexc.to_string exn) + | None -> + "\nRESULT: " ^ + (if r.hit_limit then "HIT LIMIT" else + (if r.safety_proved then "SAFE" else if r.unsafety_proved then "UNSAFE" else "POSSIBLY UNSAFE") ^ + (if r.safety_proved && r.leaks then ", MAY LEAK" else "") ^ + (if r.termination_proved then "" else if r.nontermination_proved then ", MUST DIVERGE" else "")) + +let str_of_general_results r = + Format.sprintf "(result (tool_version %s) (internal_error %b) (slayer_exn %s) (safety_proved %b) (unsafety_proved %b) (termination_proved %b) (nontermination_proved %b) (leaks %b) (hit_limit %b) (time_total %f) (time_preanalysis %f) (time_analysis %f) (time_postanalysis %f) (time_1 %f) (time_2 %f) (time_3 %f))" + r.tool_version + (r.internal_error <> None) + (match r.internal_error with Some e -> Printexc.to_string e | _ -> "None") + r.safety_proved r.unsafety_proved + r.termination_proved r.nontermination_proved + r.leaks + r.hit_limit + r.time_total + r.time_preanalysis r.time_analysis r.time_postanalysis + r.time_1 r.time_2 r.time_3 + + +let pre_analysis_tmr = Timer.create "pre-analysis" +let analysis_tmr = Timer.create "analysis" +let post_analysis_tmr = Timer.create "post-analysis" + + +let results = try ( + (* turn on backtrace printing in debug mode *) + assert(true$> Printexc.record_backtrace true ); + + (* set size of minor heap *) + Gc.set {(Gc.get()) with Gc.minor_heap_size= Config.minor_heap_size*1024*1024*8/Sys.word_size} ; + + (* Set a handler for Ctrl-C. *) + Sys.catch_break true ; + + if Config.version_only then + let dbg = ref "" in + assert(true$>( dbg := " debug" )); + let maj, min, bld, _rev = Z3.get_version () in + Printf.printf "SLAyer %s%s (Z3 dll v%i.%i.%i)\n" Version.version !dbg maj min bld ; + exit 0 + else ( + + Timer.start pre_analysis_tmr ; + + let read_sil file = + let program = Library.with_in_bin file Prog.unmarshal in + if Config.norm_in_frontend then program else TransformProgram.normalize program + in + + let program = + try + let first_fname = List.hd Config.filenames in + if Filename.check_suffix first_fname ".sil" then + read_sil first_fname + else + let args = + Array.of_list ( + "frontend" + :: Config.filenames + @ "-fe_norm" + :: (if Config.norm_in_frontend then "true" else "false") + :: Config.frontend_args) in + let test_sil = Config.testname^".sil" in + if Sys.file_exists test_sil then Sys.remove test_sil ; + match Unix.waitpid [] (Unix.create_process "frontend" args Unix.stdin Unix.stdout Unix.stderr) with + | _,Unix.WEXITED(0) -> read_sil test_sil + | _ -> exit 1 + with Sys_error(err) -> + prerr_endline err ; + exit 1 + in + + if Config.write_cfg then Prog.write_dot Config.testname ".cfg.dot" program ; + + if Config.compile_only then + exit 0 + else ( + + Initialize.initialize program ; + + Timer.stop pre_analysis_tmr ; + Timer.start analysis_tmr ; + + let results = Analysis.exec_prog program (Analysis.init program) in + + Timer.stop analysis_tmr ; + Timer.start post_analysis_tmr ; + + if Config.report_dead_code then ( + let dead_code = Analysis.dead results in + if dead_code <> [] then + Format.printf "@[Detected dead code:@ @[%a@]@]@\n" (List.fmt "@\n" Position.fmt) dead_code + ); + + let safety = + if CounterExample.disprove results then + Unsafe + else if Analysis.safe results then + Safe + else + PossiblyUnsafe + in + + Instrumentation.instrument program results ; + + { success with + safety_proved= (safety = Safe); + unsafety_proved= (safety = Unsafe); + nontermination_proved= Analysis.must_diverge results; + leaks= Analysis.leaks results <> []; + hit_limit= Analysis.hit_limit results; + } + ) + ) +) with exc -> + if Config.raise_exceptions then ( + prerr_endline (Printexc.to_string exc) ; + raise exc + ) else ( + { success with + internal_error= Some(exc); + time_total= Timer.(init.uduration +. init.sduration); + } + ) +;; +Timer.stop pre_analysis_tmr ; +Timer.stop analysis_tmr ; +Timer.stop post_analysis_tmr ; +Timer.stop Timer.init ; +(* Note: These timers miss the time spent producing the transition system file, + which is executed on exit, after the statistics and results are printed. *) + +let results = + { results with + time_total= Timer.(init.uduration +. init.sduration); + time_preanalysis= Timer.(pre_analysis_tmr.uduration +. pre_analysis_tmr.sduration); + time_analysis= Timer.(analysis_tmr.uduration +. analysis_tmr.sduration); + time_postanalysis= Timer.(post_analysis_tmr.uduration +. post_analysis_tmr.sduration) ; + } in + +flush_all () ; + +Statistics.report pre_analysis_tmr analysis_tmr post_analysis_tmr ; + +(* Gc.print_stat stderr ; *) + +print_endline ((if Config.full_results then str_of_general_results else str_of_general_results_old) results) ; + +exit (if (results.internal_error = None) then 0 else 1) diff --git a/src/slayer.mli b/src/slayer.mli new file mode 100644 index 0000000..0d9fee8 --- /dev/null +++ b/src/slayer.mli @@ -0,0 +1 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) diff --git a/test/CORRECT.txt b/test/CORRECT.txt new file mode 100644 index 0000000..cb38605 --- /dev/null +++ b/test/CORRECT.txt @@ -0,0 +1,341 @@ +cex/csll/cyclic_list_unsafe.c: POSSIBLY UNSAFE +cex/csll/destroy_iter_rem_unsafe.c: POSSIBLY UNSAFE +cex/csll/destroy_test_dangling_unsafe.c: POSSIBLY UNSAFE +cex/csll/fill_walk_drain_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove2_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove_for2_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove_for_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove_unsafe.c: POSSIBLY UNSAFE +cex/havoc/list_iterate_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/CromData_trace_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/allocate_resources_insert_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/attach_buffer_insert_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/cleanup_asyncaddressdata_remove_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/cleanup_cromdata_remove_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/cleanup_isochresourcedata_remove_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/cromdata_add_remove_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/free_resources_remove_entry_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/is_on_list_flat_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/set_local_properties_plist_entry_unsafe.c: POSSIBLY UNSAFE +cex/simple/changing_truth_value_unsafe.c: POSSIBLY UNSAFE +cex/simple/changing_truth_value_unsafe_garbage.c: POSSIBLY UNSAFE +cex/simple/complicated_safe.c: SAFE +cex/simple/complicated_unsafe.c: POSSIBLY UNSAFE +cex/simple/maybe_malloc_then_write.c: POSSIBLY UNSAFE +cex/simple/no_loops_unsafe.c: POSSIBLY UNSAFE +cex/simple/nontrivial_list_2_unsafe.c: POSSIBLY UNSAFE +cex/simple/nontrivial_list_2_unsafe_garbage.c: POSSIBLY UNSAFE +cex/simple/nontrivial_list_unsafe.c: POSSIBLY UNSAFE +cex/simple/serious_unsafe.c: POSSIBLY UNSAFE +cex/simple/simple_list_unsafe.c: POSSIBLY UNSAFE +cex/simple/simple_loop_unsafe.c: POSSIBLY UNSAFE +cex/simple/simple_loop_unsafe_garbage.c: POSSIBLY UNSAFE +cex/simple/two_loops_unsafe.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_4.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_easy.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_even_less_easy.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_less_easy.c: POSSIBLY UNSAFE +cex/sll/append_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/append_ret_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/append_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/append_unsafe.c: POSSIBLY UNSAFE +cex/sll/copy_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/copy_leak_unsafe.c: POSSIBLY UNSAFE +cex/sll/copy_unsafe.c: POSSIBLY UNSAFE +cex/sll/create_body_unsafe.c: POSSIBLY UNSAFE +cex/sll/create_kernel_unsafe.c: POSSIBLY UNSAFE +cex/sll/create_via_tmps_unsafe.c: POSSIBLY UNSAFE +cex/sll/destroy_sll_unsafe.c: POSSIBLY UNSAFE +cex/sll/filter_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/filter_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/filter_unsafe.c: POSSIBLY UNSAFE +cex/sll/insertion_sort_inlined_lead_unsafe.c: POSSIBLY UNSAFE +cex/sll/insertion_sort_inlined_unsafe.c: POSSIBLY UNSAFE +cex/sll/insertion_sort_unsafe.c: POSSIBLY UNSAFE +cex/sll/list_of_objects.c: POSSIBLY UNSAFE +cex/sll/list_of_objects_unsafe.c: POSSIBLY UNSAFE +cex/sll/remove_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div2_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div3_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div4_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_leak2_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_leak_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_negative_sublists_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_seg_cyclic_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_seg_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_unsafe.c: POSSIBLY UNSAFE +cex/sll/splice_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse3_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_1lists_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_2lists_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_5lists_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_seg_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_twice_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/create_rec2_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/create_rec3_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/create_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/find_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/insertion_sort_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/merge_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/reverse_app_ret_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/reverse_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_rec_nondet_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_seg_rec_nondet_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_seg_rec_unsafe.c: POSSIBLY UNSAFE +csll/cyclic_list.c: SAFE, MAY LEAK +csll/destroy.c: SAFE +csll/destroy_iter_rem.c: SAFE +csll/destroy_test_dangling.c: SAFE +csll/fill_walk_drain.c: SAFE +csll/remove.c: SAFE +csll/remove2.c: SAFE, MAY LEAK +csll/remove_for.c: SAFE +csll/remove_for2.c: SAFE +csll/remove_leak.c: SAFE, MAY LEAK +csll/remove_leak_nd_ret.c: SAFE, MAY LEAK +dev/frec.c: SAFE +dev/irreducible.c: SAFE +dev/store.c: SAFE, MAY LEAK +dev/straight.c: SAFE, MAY LEAK +dev/straight_func.c: SAFE +havoc/list_iterate.c: SAFE, MAY LEAK +kmdf/1394/CromData_trace.c: POSSIBLY UNSAFE +kmdf/1394/address_range_plist_entry.c: SAFE, MAY LEAK +kmdf/1394/allocate_resources_insert_head_list.c: SAFE, MAY LEAK +kmdf/1394/attach_buffer_insert_head_list.c: SAFE, MAY LEAK +kmdf/1394/attach_completion_routine_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/callback_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/cleanup_asyncaddressdata_remove_head_list.c: SAFE +kmdf/1394/cleanup_cromdata_remove_head_list.c: SAFE +kmdf/1394/cleanup_isochdetachdata_remove_head_list.c: SAFE +kmdf/1394/cleanup_isochresourcedata_remove_head_list.c: SAFE +kmdf/1394/cromdata_add_remove.c: SAFE, MAY LEAK +kmdf/1394/cromdata_add_remove_fs.c: SAFE, MAY LEAK +kmdf/1394/free_resources_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/initialize_list_head.c: SAFE +kmdf/1394/is_on_list_flat.c: SAFE, MAY LEAK +kmdf/1394/is_on_list_via_devext.c: SAFE, MAY LEAK +kmdf/1394/isoch_detach_data_shares_devext.c: SAFE +kmdf/1394/set_local_properties_plist_entry.c: SAFE, MAY LEAK +kmdf/1394/timeout_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/wdf_device_create.c: SAFE +kmdf/1394/wdf_device_init_set_pnp_power_event_callbacks.c: SAFE +kmdf/1394/wdf_driver_config_init.c: SAFE +kmdf/1394/wdf_driver_create.c: SAFE, MAY LEAK +kmdf/1394/wdf_object_attributes_init_context_type.c: SAFE +kmdf/1394/wdf_pnppower_event_callbacks.c: SAFE +kmdf/microtests/WdfStringCreate_ObjectDelete.c: SAFE +kmdf/toaster/bus/dynamic/dynamic.c: SAFE +kmdf/toaster/bus/static/static.c: SAFE +kmdf/toaster/bus/static_fail1/static_fail1.c: POSSIBLY UNSAFE +kmdf/toaster/func/featured/featured.c: SAFE +kmdf/toaster/func/simple/simple.c: SAFE +kmdf/toaster/func/simple_fail1/simple_fail1.c: POSSIBLY UNSAFE +multi/link/link.c: SAFE +other/ExAllocatePoolWithTag.c: SAFE, MAY LEAK +other/addr_of_global_struct.c: SAFE +other/address_arith.c: POSSIBLY UNSAFE +other/address_of.c: SAFE +other/address_of2.c: SAFE +other/address_of_global.c: SAFE +other/address_of_malloced_struct.c: SAFE +other/address_of_struct.c: SAFE +other/address_taken_assigned_by_return.c: SAFE +other/alloc_object_into_array.c: SAFE +other/anonymous_union.c: SAFE +other/array_access.c: SAFE +other/array_arguments_heap.c: SAFE +other/array_arguments_stack.c: SAFE +other/array_in_formal.c: SAFE +other/array_of_guids.c: SAFE +other/array_of_structs.c: SAFE +other/assume_assert.c: POSSIBLY UNSAFE +other/backjump.c: SAFE +other/bitfield.c: SAFE +other/bool_to_int.c: SAFE +other/call.c: SAFE +other/call_arg.c: SAFE +other/call_arg_unique.c: SAFE +other/cast.c: POSSIBLY UNSAFE +other/cast_1394.c: SAFE +other/cast_bt_types.c: POSSIBLY UNSAFE +other/cast_guard_implicit.c: SAFE +other/cast_guard_int.c: SAFE +other/cast_guard_ptr.c: SAFE +other/compound_assignment.c: SAFE +other/containing_record.c: SAFE +other/control_guard.c: SAFE +other/dead_code.c: SAFE +other/deref_NULL2.c: POSSIBLY UNSAFE +other/deref_ZERO.c: POSSIBLY UNSAFE +other/deref_via_call.c: SAFE +other/deref_via_call2.c: SAFE, MAY LEAK +other/dynamic_size_array.c: SAFE +other/empty.c: SAFE +other/forwdjump.c: SAFE +other/free_free.c: POSSIBLY UNSAFE +other/free_local.c: POSSIBLY UNSAFE +other/fun_arg_order.c: SAFE +other/fused_assign_1.c: SAFE +other/fused_assign_2.c: SAFE +other/get_untyped_buf.c: SAFE +other/global_struct_fields.c: SAFE +other/global_var.c: SAFE +other/globals_per_proc.c: SAFE +other/icall.c: SAFE +other/icall_with_global1.c: SAFE +other/icall_with_global2.c: SAFE +other/icall_with_global3.c: SAFE +other/icall_with_global4.c: SAFE +other/if.c: SAFE +other/if_integer.c: SAFE +other/if_pointer.c: POSSIBLY UNSAFE +other/ifguard.c: SAFE +other/inline_args.c: SAFE +other/inline_criteria.c: SAFE +other/mainret.c: SAFE +other/malloc.c: SAFE, MAY LEAK +other/malloc_free.c: SAFE +other/malloc_free_struct.c: SAFE +other/malloc_struct.c: SAFE, MAY LEAK +other/multireturn.c: SAFE +other/nested_struct.c: SAFE, MAY LEAK +other/pointer_subtraction.c: SAFE +other/reachable_globals.c: SAFE, MAY LEAK +other/rep_3_f_int_star.c: SAFE, MAY LEAK +other/rep_4_f_int_star.c: SAFE, MAY LEAK +other/rep_4_f_void_star.c: SAFE, MAY LEAK +other/return.c: SAFE +other/return_struct.c: SAFE +other/sized_array_simple.c: SAFE +other/small_ites.c: SAFE +other/small_ites16.c: SAFE +other/small_ites32.c: SAFE +other/small_ites4.c: SAFE +other/small_ites8.c: SAFE +other/store_to_0x0.c: POSSIBLY UNSAFE +other/store_to_0x0_fix.c: POSSIBLY UNSAFE +other/straightline.c: SAFE +other/struct.c: SAFE, MAY LEAK +other/struct_all.c: SAFE +other/struct_argument.c: SAFE, MAY LEAK +other/struct_argument_esp_fail.c: SAFE, MAY LEAK +other/struct_argument_cl_fail.c: SAFE, MAY LEAK +other/struct_array_copy.c: SAFE +other/struct_assign_1.c: SAFE +other/struct_assign_2.c: SAFE +other/struct_assign_3.c: SAFE +other/struct_assign_4.c: SAFE +other/struct_assign_5.c: SAFE +other/struct_field.c: SAFE, MAY LEAK +other/struct_init.c: SAFE +other/struct_local.c: SAFE +other/struct_pass.c: SAFE +other/switch.c: SAFE +other/two_elt_array_fptr.c: SAFE +other/two_elt_array_global.c: SAFE +other/two_elt_array_local.c: SAFE +other/unused_global.c: SAFE +other/unused_global_2.c: SAFE +other/update_global_var.c: SAFE +other/while.c: SAFE +other/while2loads.c: SAFE, MAY LEAK +other/write_to_busInfo_struct.c: SAFE +other/writer_reader.c: SAFE +sll/append.c: SAFE +sll/append_fs.c: SAFE +sll/append_ret.c: SAFE +sll/append_ret_fs.c: SAFE +sll/copy.c: SAFE +sll/copy_leak.c: SAFE, MAY LEAK +sll/create.c: SAFE, MAY LEAK +sll/create_body.c: SAFE +sll/create_fs.c: SAFE +sll/create_fs_via_tmps.c: SAFE +sll/create_kernel.c: SAFE, MAY LEAK +sll/create_seg.c: SAFE, MAY LEAK +sll/create_via_tmps.c: SAFE +sll/destroy.c: SAFE +sll/destroy_seg.c: SAFE +sll/destroy_seg_leak.c: SAFE, MAY LEAK +sll/filter.c: SAFE +sll/filter_fs.c: SAFE +sll/filter_ret.c: SAFE +sll/find.c: SAFE +sll/find_ret.c: SAFE +sll/insert.c: SAFE +sll/insert_ret.c: SAFE +sll/insertion_sort.c: SAFE +sll/insertion_sort_inlined.c: SAFE +sll/insertion_sort_inlined_leak.c: SAFE, MAY LEAK +sll/print.c: SAFE +sll/print_fs.c: SAFE +sll/remove_ret.c: SAFE +sll/reverse.c: SAFE +sll/reverse_div.c: SAFE +sll/reverse_div2.c: SAFE +sll/reverse_div3.c: SAFE, MAY LEAK +sll/reverse_div4.c: SAFE, MAY LEAK +sll/reverse_div5.c: POSSIBLY UNSAFE +sll/reverse_leak.c: SAFE, MAY LEAK +sll/reverse_leak2.c: SAFE, MAY LEAK +sll/reverse_negative_sublists.c: SAFE +sll/reverse_negative_sublists1.c: SAFE +sll/reverse_negative_sublists1_leak.c: SAFE, MAY LEAK +sll/reverse_negative_sublists1_unsafe.c: POSSIBLY UNSAFE +sll/reverse_negative_sublists2.c: SAFE +sll/reverse_negative_sublists2_leak.c: SAFE, MAY LEAK +sll/reverse_negative_sublists2_unsafe.c: POSSIBLY UNSAFE +sll/reverse_negative_sublists_fs.c: SAFE +sll/reverse_ret.c: SAFE +sll/reverse_seg.c: SAFE +sll/reverse_seg_cyclic.c: SAFE, MAY LEAK +sll/splice.c: SAFE +sll/splice_fs.c: SAFE +sll/straightline.c: SAFE, MAY LEAK +sll/traverse.c: SAFE +sll/traverse2.c: SAFE +sll/traverse3.c: SAFE +sll/traverse4.c: SAFE +sll/traverse5.c: SAFE +sll/traverse_1lists.c: SAFE +sll/traverse_2lists.c: SAFE +sll/traverse_3lists.c: SAFE +sll/traverse_4lists.c: SAFE +sll/traverse_5lists.c: SAFE +sll/traverse_seg.c: SAFE +sll/traverse_seg2.c: SAFE, MAY LEAK +sll/traverse_twice.c: SAFE +sll_rec/append_ret_rec.c: SAFE, MAY LEAK +sll_rec/create_rec.c: SAFE, MAY LEAK +sll_rec/create_rec2.c: SAFE, MAY LEAK +sll_rec/create_rec3.c: SAFE, MAY LEAK +sll_rec/destroy_rec.c: SAFE +sll_rec/find_rec.c: SAFE, MAY LEAK +sll_rec/insert_rec.c: SAFE, MAY LEAK +sll_rec/insert_ret_rec.c: SAFE, MAY LEAK +sll_rec/insertion_sort_rec.c: SAFE, MAY LEAK +sll_rec/merge_rec.c: SAFE, MAY LEAK +sll_rec/merge_rec1.c: SAFE, MAY LEAK +sll_rec/merge_sort.c: SAFE, MAY LEAK +sll_rec/quick_sort.c: SAFE, MAY LEAK +sll_rec/remove_rec.c: SAFE, MAY LEAK +sll_rec/remove_ret_rec.c: SAFE, MAY LEAK +sll_rec/reverse_app_ret_rec.c: SAFE, MAY LEAK +sll_rec/reverse_rec.c: SAFE, MAY LEAK +sll_rec/reverse_ret_rec.c: SAFE, MAY LEAK +sll_rec/splice_rec.c: SAFE, MAY LEAK +sll_rec/split.c: SAFE, MAY LEAK +sll_rec/traverse_rec.c: SAFE, MAY LEAK +sll_rec/traverse_rec_nondet.c: SAFE, MAY LEAK +sll_rec/traverse_seg_rec.c: SAFE, MAY LEAK +sll_rec/traverse_seg_rec_nondet.c: SAFE, MAY LEAK +ssa/branch.c: SAFE +ssa/dloop.c: SAFE +ssa/fig-19_4.c: SAFE +ssa/straightline.c: SAFE diff --git a/test/EXPECTED.txt b/test/EXPECTED.txt new file mode 100644 index 0000000..42172a8 --- /dev/null +++ b/test/EXPECTED.txt @@ -0,0 +1,358 @@ +cex/csll/cyclic_list_unsafe.c: POSSIBLY UNSAFE +cex/csll/destroy_iter_rem_unsafe.c: POSSIBLY UNSAFE +cex/csll/destroy_test_dangling_unsafe.c: POSSIBLY UNSAFE +cex/csll/fill_walk_drain_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove2_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove_for2_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove_for_unsafe.c: POSSIBLY UNSAFE +cex/csll/remove_unsafe.c: POSSIBLY UNSAFE +cex/havoc/list_iterate_unsafe.c: TIMEOUT +cex/kmdf/CromData_trace_unsafe.c: Internal Error: Failure("\nUndefined procedure: MmBuildMdlForNonPagedPool\n") +cex/kmdf/allocate_resources_insert_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/attach_buffer_insert_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/cleanup_asyncaddressdata_remove_head_list_unsafe.c: TIMEOUT +cex/kmdf/cleanup_cromdata_remove_head_list_unsafe.c: TIMEOUT +cex/kmdf/cleanup_isochresourcedata_remove_head_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/cromdata_add_remove_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/free_resources_remove_entry_list_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/is_on_list_flat_unsafe.c: POSSIBLY UNSAFE +cex/kmdf/set_local_properties_plist_entry_unsafe.c: POSSIBLY UNSAFE +cex/simple/changing_truth_value_unsafe.c: POSSIBLY UNSAFE +cex/simple/changing_truth_value_unsafe_garbage.c: POSSIBLY UNSAFE +cex/simple/complicated_safe.c: POSSIBLY UNSAFE +cex/simple/complicated_unsafe.c: POSSIBLY UNSAFE +cex/simple/maybe_malloc_then_write.c: POSSIBLY UNSAFE +cex/simple/no_loops_unsafe.c: POSSIBLY UNSAFE +cex/simple/nontrivial_list_2_unsafe.c: POSSIBLY UNSAFE +cex/simple/nontrivial_list_2_unsafe_garbage.c: POSSIBLY UNSAFE +cex/simple/nontrivial_list_unsafe.c: POSSIBLY UNSAFE +cex/simple/serious_unsafe.c: POSSIBLY UNSAFE +cex/simple/simple_list_unsafe.c: POSSIBLY UNSAFE +cex/simple/simple_loop_unsafe.c: POSSIBLY UNSAFE +cex/simple/simple_loop_unsafe_garbage.c: POSSIBLY UNSAFE +cex/simple/two_loops_unsafe.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_4.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_easy.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_even_less_easy.c: POSSIBLY UNSAFE +cex/simple/very_simple_unsafe_garbage_less_easy.c: POSSIBLY UNSAFE +cex/sll/append_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/append_ret_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/append_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/append_unsafe.c: POSSIBLY UNSAFE +cex/sll/copy_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/copy_leak_unsafe.c: POSSIBLY UNSAFE +cex/sll/copy_unsafe.c: POSSIBLY UNSAFE +cex/sll/create_body_unsafe.c: POSSIBLY UNSAFE +cex/sll/create_kernel_unsafe.c: POSSIBLY UNSAFE +cex/sll/create_via_tmps_unsafe.c: POSSIBLY UNSAFE +cex/sll/destroy_sll_unsafe.c: POSSIBLY UNSAFE +cex/sll/filter_fs_unsafe.c: POSSIBLY UNSAFE +cex/sll/filter_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/filter_unsafe.c: POSSIBLY UNSAFE +cex/sll/insertion_sort_inlined_lead_unsafe.c: POSSIBLY UNSAFE +cex/sll/insertion_sort_inlined_unsafe.c: POSSIBLY UNSAFE +cex/sll/insertion_sort_unsafe.c: POSSIBLY UNSAFE +cex/sll/list_of_objects.c: POSSIBLY UNSAFE +cex/sll/list_of_objects_unsafe.c: POSSIBLY UNSAFE +cex/sll/remove_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div2_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div3_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div4_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_div_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_leak2_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_leak_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_negative_sublists_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_ret_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_seg_cyclic_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_seg_unsafe.c: POSSIBLY UNSAFE +cex/sll/reverse_unsafe.c: POSSIBLY UNSAFE +cex/sll/splice_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse3_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_1lists_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_2lists_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_5lists_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_seg_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_twice_unsafe.c: POSSIBLY UNSAFE +cex/sll/traverse_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/create_rec2_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/create_rec3_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/create_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/find_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/insertion_sort_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/merge_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/reverse_app_ret_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/reverse_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_rec_nondet_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_rec_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_seg_rec_nondet_unsafe.c: POSSIBLY UNSAFE +cex/sll_rec/traverse_seg_rec_unsafe.c: POSSIBLY UNSAFE +csll/cyclic_list.c: SAFE, MAY LEAK +csll/destroy.c: SAFE +csll/destroy_iter_rem.c: SAFE +csll/destroy_test_dangling.c: SAFE, MAY LEAK +csll/fill_walk_drain.c: POSSIBLY UNSAFE +csll/remove.c: SAFE +csll/remove2.c: SAFE, MAY LEAK +csll/remove_for.c: SAFE +csll/remove_for2.c: SAFE +csll/remove_leak.c: SAFE, MAY LEAK +csll/remove_leak_nd_ret.c: SAFE, MAY LEAK +dev/frec.c: SAFE +dev/irreducible.c: SAFE +dev/store.c: TIMEOUT +dev/straight.c: SAFE, MAY LEAK +dev/straight_func.c: SAFE +havoc/list_iterate.c: TIMEOUT +kmdf/1394/CromData_trace.c: Internal Error: Failure("\nUndefined procedure: MmBuildMdlForNonPagedPool\n") +kmdf/1394/address_range_plist_entry.c: SAFE, MAY LEAK +kmdf/1394/allocate_resources_insert_head_list.c: SAFE, MAY LEAK +kmdf/1394/attach_buffer_insert_head_list.c: SAFE, MAY LEAK +kmdf/1394/attach_completion_routine_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/callback_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/cleanup_asyncaddressdata_remove_head_list.c: SAFE +kmdf/1394/cleanup_cromdata_remove_head_list.c: SAFE +kmdf/1394/cleanup_isochdetachdata_remove_head_list.c: SAFE +kmdf/1394/cleanup_isochresourcedata_remove_head_list.c: SAFE +kmdf/1394/cromdata_add_remove.c: SAFE, MAY LEAK +kmdf/1394/cromdata_add_remove_fs.c: SAFE, MAY LEAK +kmdf/1394/free_resources_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/initialize_list_head.c: SAFE +kmdf/1394/is_on_list_flat.c: SAFE, MAY LEAK +kmdf/1394/is_on_list_via_devext.c: SAFE, MAY LEAK +kmdf/1394/isoch_detach_data_shares_devext.c: SAFE +kmdf/1394/set_local_properties_plist_entry.c: SAFE, MAY LEAK +kmdf/1394/timeout_remove_entry_list.c: SAFE, MAY LEAK +kmdf/1394/wdf_device_create.c: SAFE +kmdf/1394/wdf_device_init_set_pnp_power_event_callbacks.c: SAFE +kmdf/1394/wdf_driver_config_init.c: SAFE +kmdf/1394/wdf_driver_create.c: SAFE +kmdf/1394/wdf_object_attributes_init_context_type.c: SAFE +kmdf/1394/wdf_pnppower_event_callbacks.c: SAFE +kmdf/microtests/WdfStringCreate_ObjectDelete.c: SAFE +kmdf/toaster/bus/dynamic/dynamic.c: SAFE +kmdf/toaster/bus/static/static.c: SAFE +kmdf/toaster/bus/static_fail1/static_fail1.c: POSSIBLY UNSAFE +kmdf/toaster/filter/generic/generic.c: SAFE +kmdf/toaster/filter/sideband/sideband.c: SAFE +kmdf/toaster/func/featured/featured.c: SAFE +kmdf/toaster/func/simple/simple.c: SAFE +kmdf/toaster/func/simple_fail1/simple_fail1.c: POSSIBLY UNSAFE +kmdf/toaster/toastmon/toastmon.c: SAFE +kmdf/usb/1.c: Internal Error: Failure("cl died") +kmdf/usb/2.c: Internal Error: Failure("cl died") +kmdf/usb/3.c: Internal Error: Failure("cl died") +kmdf/usb/4.c: Internal Error: Failure("cl died") +kmdf/usb/5.c: Internal Error: Failure("cl died") +kmdf/usb/6.c: Internal Error: Failure("cl died") +kmdf/usb/7.c: Internal Error: Failure("cl died") +kmdf/usb/8.c: Internal Error: Failure("cl died") +kmdf/usb/9.c: Internal Error: Failure("cl died") +multi/link/link.c: SAFE +other/ExAllocatePoolWithTag.c: SAFE, MAY LEAK +other/addr_of_global_struct.c: SAFE +other/address_arith.c: POSSIBLY UNSAFE +other/address_of.c: SAFE +other/address_of2.c: SAFE +other/address_of_global.c: SAFE +other/address_of_malloced_struct.c: SAFE +other/address_of_struct.c: SAFE +other/address_taken_assigned_by_return.c: SAFE +other/alloc_object_into_array.c: SAFE, MAY LEAK +other/anonymous_union.c: SAFE +other/array_access.c: SAFE +other/array_arguments_heap.c: SAFE +other/array_arguments_stack.c: SAFE +other/array_in_formal.c: SAFE +other/array_of_guids.c: SAFE +other/array_of_structs.c: Internal Error: Failure("\nconversion to IntegerSort failed: f!6\n") +other/assume_assert.c: POSSIBLY UNSAFE +other/backjump.c: SAFE +other/bitfield.c: SAFE +other/bool_to_int.c: SAFE +other/call.c: SAFE +other/call_arg.c: SAFE +other/call_arg_unique.c: SAFE +other/cast.c: POSSIBLY UNSAFE +other/cast_1394.c: SAFE +other/cast_bt_types.c: POSSIBLY UNSAFE +other/cast_guard_implicit.c: Internal Error: ill-sorted: (x!3I == a!1P) +other/cast_guard_int.c: POSSIBLY UNSAFE +other/cast_guard_ptr.c: POSSIBLY UNSAFE +other/compound_assignment.c: SAFE +other/containing_record.c: SAFE +other/control_guard.c: SAFE +other/copy_struct_on_heap.c: SAFE +other/copy_struct_on_stack.c: SAFE +other/dead_code.c: SAFE +other/deref_NULL2.c: POSSIBLY UNSAFE +other/deref_ZERO.c: POSSIBLY UNSAFE +other/deref_via_call.c: SAFE +other/deref_via_call2.c: SAFE, MAY LEAK +other/deref_via_call3.c: SAFE +other/dynamic_size_array.c: SAFE +other/empty.c: SAFE +other/forwdjump.c: SAFE +other/free_free.c: POSSIBLY UNSAFE +other/free_local.c: POSSIBLY UNSAFE +other/fun_arg_order.c: SAFE +other/fused_assign_1.c: SAFE +other/fused_assign_2.c: SAFE +other/get_untyped_buf.c: POSSIBLY UNSAFE +other/global_struct_fields.c: SAFE +other/global_var.c: SAFE +other/globals_per_proc.c: SAFE +other/icall.c: SAFE +other/icall_with_global1.c: SAFE +other/icall_with_global2.c: SAFE +other/icall_with_global3.c: SAFE +other/icall_with_global4.c: SAFE +other/if.c: SAFE +other/if_integer.c: SAFE +other/if_pointer.c: POSSIBLY UNSAFE +other/ifguard.c: SAFE +other/inline_args.c: SAFE +other/inline_criteria.c: SAFE +other/mainret.c: SAFE +other/malloc.c: SAFE, MAY LEAK +other/malloc_free.c: SAFE +other/malloc_free_struct.c: SAFE +other/malloc_struct.c: SAFE, MAY LEAK +other/multireturn.c: SAFE +other/nested_struct.c: SAFE, MAY LEAK +other/pointer_subtraction.c: Internal Error: Failure("\nconversion to IntegerSort failed: b!2\n") +other/reachable_globals.c: SAFE, MAY LEAK +other/rep_3_f_int_star.c: SAFE, MAY LEAK +other/rep_4_f_int_star.c: SAFE, MAY LEAK +other/rep_4_f_void_star.c: SAFE, MAY LEAK +other/return.c: SAFE +other/return_struct.c: SAFE +other/sized_array_simple.c: SAFE +other/sized_arrays.c: Internal Error: Failure("ASSIGN(non-ASSIGN)") +other/small_ites.c: SAFE +other/small_ites16.c: SAFE +other/small_ites32.c: SAFE +other/small_ites4.c: SAFE +other/small_ites8.c: SAFE +other/store_to_0x0.c: POSSIBLY UNSAFE +other/store_to_0x0_fix.c: POSSIBLY UNSAFE +other/straightline.c: SAFE +other/struct.c: SAFE, MAY LEAK +other/struct_all.c: SAFE +other/struct_argument.c: SAFE, MAY LEAK +other/struct_argument_esp_fail.c: Internal Error: Failure("UNARY(UNARY)") +other/struct_argument_cl_fail.c: Internal Error: Failure("cl died") +other/struct_array_copy.c: SAFE +other/struct_assign_1.c: SAFE +other/struct_assign_2.c: SAFE +other/struct_assign_3.c: SAFE +other/struct_assign_4.c: SAFE +other/struct_assign_5.c: SAFE +other/struct_field.c: SAFE, MAY LEAK +other/struct_init.c: SAFE +other/struct_local.c: SAFE +other/struct_pass.c: SAFE +other/switch.c: SAFE +other/track_global_frees.c: SAFE +other/two_elt_array_fptr.c: POSSIBLY UNSAFE +other/two_elt_array_global.c: SAFE +other/two_elt_array_local.c: SAFE +other/unused_global.c: SAFE +other/unused_global_2.c: SAFE +other/update_global_var.c: SAFE +other/while.c: SAFE +other/while2loads.c: SAFE, MAY LEAK +other/write_to_busInfo_struct.c: SAFE +other/writer_reader.c: SAFE +sll/append.c: SAFE +sll/append_fs.c: SAFE +sll/append_ret.c: SAFE +sll/append_ret_fs.c: SAFE +sll/copy.c: SAFE +sll/copy_leak.c: SAFE, MAY LEAK +sll/create.c: SAFE, MAY LEAK +sll/create_body.c: SAFE +sll/create_fs.c: SAFE +sll/create_fs_via_tmps.c: SAFE +sll/create_kernel.c: SAFE, MAY LEAK +sll/create_seg.c: SAFE, MAY LEAK +sll/create_via_tmps.c: SAFE +sll/destroy.c: SAFE +sll/destroy_seg.c: SAFE +sll/destroy_seg_leak.c: SAFE, MAY LEAK +sll/filter.c: SAFE +sll/filter_fs.c: SAFE +sll/filter_ret.c: SAFE +sll/find.c: SAFE +sll/find_ret.c: SAFE +sll/insert.c: SAFE +sll/insert_ret.c: SAFE +sll/insertion_sort.c: SAFE +sll/insertion_sort_inlined.c: SAFE +sll/insertion_sort_inlined_leak.c: SAFE, MAY LEAK +sll/print.c: SAFE +sll/print_fs.c: SAFE +sll/remove_ret.c: SAFE +sll/reverse.c: SAFE +sll/reverse_div.c: SAFE +sll/reverse_div2.c: SAFE +sll/reverse_div3.c: POSSIBLY UNSAFE +sll/reverse_div4.c: SAFE, MAY LEAK +sll/reverse_div5.c: POSSIBLY UNSAFE +sll/reverse_leak.c: SAFE, MAY LEAK +sll/reverse_leak2.c: SAFE, MAY LEAK +sll/reverse_negative_sublists.c: SAFE +sll/reverse_negative_sublists1.c: SAFE +sll/reverse_negative_sublists1_leak.c: SAFE, MAY LEAK +sll/reverse_negative_sublists1_unsafe.c: POSSIBLY UNSAFE +sll/reverse_negative_sublists2.c: SAFE +sll/reverse_negative_sublists2_leak.c: SAFE, MAY LEAK +sll/reverse_negative_sublists2_unsafe.c: POSSIBLY UNSAFE +sll/reverse_negative_sublists_fs.c: SAFE +sll/reverse_ret.c: SAFE +sll/reverse_seg.c: SAFE +sll/reverse_seg_cyclic.c: SAFE, MAY LEAK +sll/splice.c: SAFE +sll/splice_fs.c: SAFE +sll/straightline.c: SAFE, MAY LEAK +sll/traverse.c: SAFE +sll/traverse2.c: SAFE +sll/traverse3.c: SAFE +sll/traverse4.c: SAFE +sll/traverse5.c: SAFE +sll/traverse_1lists.c: SAFE +sll/traverse_2lists.c: SAFE +sll/traverse_3lists.c: SAFE +sll/traverse_4lists.c: SAFE +sll/traverse_5lists.c: SAFE +sll/traverse_seg.c: SAFE +sll/traverse_seg2.c: SAFE, MAY LEAK +sll/traverse_twice.c: SAFE +sll_rec/append_ret_rec.c: SAFE, MAY LEAK +sll_rec/create_rec.c: SAFE, MAY LEAK +sll_rec/create_rec2.c: SAFE, MAY LEAK +sll_rec/create_rec3.c: SAFE, MAY LEAK +sll_rec/destroy_rec.c: SAFE +sll_rec/find_rec.c: SAFE, MAY LEAK +sll_rec/insert_rec.c: SAFE, MAY LEAK +sll_rec/insert_ret_rec.c: SAFE, MAY LEAK +sll_rec/insertion_sort_rec.c: SAFE, MAY LEAK +sll_rec/merge_rec.c: SAFE, MAY LEAK +sll_rec/merge_rec1.c: SAFE, MAY LEAK +sll_rec/merge_sort.c: SAFE, MAY LEAK +sll_rec/quick_sort.c: SAFE, MAY LEAK +sll_rec/remove_rec.c: SAFE, MAY LEAK +sll_rec/remove_ret_rec.c: SAFE, MAY LEAK +sll_rec/reverse_app_ret_rec.c: SAFE, MAY LEAK +sll_rec/reverse_rec.c: SAFE, MAY LEAK +sll_rec/reverse_ret_rec.c: SAFE, MAY LEAK +sll_rec/splice_rec.c: SAFE, MAY LEAK +sll_rec/split.c: SAFE, MAY LEAK +sll_rec/traverse_rec.c: SAFE, MAY LEAK +sll_rec/traverse_rec_nondet.c: SAFE, MAY LEAK +sll_rec/traverse_seg_rec.c: SAFE, MAY LEAK +sll_rec/traverse_seg_rec_nondet.c: SAFE, MAY LEAK +ssa/branch.c: SAFE +ssa/dloop.c: SAFE +ssa/fig-19_4.c: SAFE +ssa/straightline.c: SAFE diff --git a/test/Makefile b/test/Makefile new file mode 100644 index 0000000..3323d5e --- /dev/null +++ b/test/Makefile @@ -0,0 +1,265 @@ +# Copyright (c) Microsoft Corporation. All rights reserved. + +## parameters + +# directories containing tests to run +DIR?=other ssa sll kmdf/1394 csll dev cex #sll_rec + +# directories containing directories of multi-file tests to run +# (Make sure MDIR (eg, kmdf/1394) is disjoint from DIR (eg, kmdf/toaster/bus/static).) +TOASTER_BUS=kmdf/toaster/bus/static kmdf/toaster/bus/dynamic kmdf/toaster/bus/static_fail1 +TOASTER_FUNC=kmdf/toaster/func/simple kmdf/toaster/func/featured kmdf/toaster/func/simple_fail1 +TOASTER_FILTER=kmdf/toaster/filter/generic kmdf/toaster/filter/sideband +TOASTER_TOASTMON=kmdf/toaster/toastmon +MDIR?=multi/link $(TOASTER_BUS) $(TOASTER_FUNC) $(TOASTER_FILTER) $(TOASTER_TOASTMON) + +# additional arguments to pass to slayer +ARG?= + +# limits +TIMEOUT?=1200 +MEMOUT?=3072 + +# previous tsv file +TSV?=RESULT.curr.tsv + +# version to tag results with +VER?=$(shell git rev-parse --short HEAD) + + +# commands which may need to be explicitly specified if shadowed in $PATH +DIFF?=diff +FIND?=find +GREP?=grep + + +## environment-specific config + +ifeq (${OS}, Windows_NT) +# in windows format since it is passed to wlimit +CURDIR_WIN=$(shell cygpath -m $(CURDIR)) +TST=$(shell cygpath -m $(CURDIR)) +EXE=.exe +else +TST=$(CURDIR) +EXE= +endif + +BUILD_DIR=_build${ARCH} + +# executable to test +SLAYER_EXE=$(CURDIR)/../bin/slayer$(EXE) +SLAYER_EXE_WIN=$(CURDIR_WIN)/../bin/slayer$(EXE) +ifeq (${OS}, Windows_NT) +FRONTEND_EXE=$(shell dirname $(SLAYER_EXE))/frontend$(EXE) +endif + + +default: test + +help: + @cat README + +bugs: + @echo "EXPECTED | CORRECT" + @$(DIFF) -y -W 160 --suppress-common-lines EXPECTED.txt CORRECT.txt || true + +report: + @$(GREP) Expected RESULT.curr.txt + +bin: + mkdir bin + +# compile result gathering script +bin/gather_results$(EXE): scripts/gather_results.ml bin + @ocamlbuild -build-dir $(BUILD_DIR) -no-links -libs str,unix scripts/gather_results.native + @cp -p $(BUILD_DIR)/scripts/gather_results.native bin/gather_results$(EXE) + +# compile result comparison script +bin/compare_results$(EXE): scripts/compare_results.ml bin + @ocamlbuild -build-dir $(BUILD_DIR) -no-links -libs str scripts/compare_results.native + @cp -p $(BUILD_DIR)/scripts/compare_results.native bin/compare_results$(EXE) + + +# C programs under test +TestCs:=$(shell $(FIND) $(DIR) -name '*.c') +TestDirs:=$(MDIR) +UnsortedCompSils:=$(patsubst %.c,%.sil,$(TestCs)) $(foreach dir,$(TestDirs),$(dir)/$(notdir $(dir)).sil) +CompSils:=$(shell scripts/sort_tests.ml -tsv $(TSV) $(UnsortedCompSils)) +ifeq (${OS}, Windows_NT) +TestSils:=$(CompSils) +else +TestSils:=$(shell $(FIND) $(DIR) -name *.sil) +endif +SlayerOuts:=$(patsubst %.sil,%.slayer.out,$(TestSils)) + +TEST_FE=$(CURDIR)/bin/frontend$(EXE) +TEST_BE=$(CURDIR)/bin/slayer$(EXE) +TEST_FE_EXE=$(TST)/bin/frontend$(EXE) +TEST_BE_EXE=$(TST)/bin/slayer$(EXE) + +.PHONY: copy_exes +copy_exes: $(SLAYER_EXE) $(FRONTEND_EXE) + @mkdir -p `dirname $(TEST_FE_EXE)` + @cp -p -f $(FRONTEND_EXE) $(TEST_FE_EXE) + @mkdir -p `dirname $(TEST_BE_EXE)` + @cp -p -f $(SLAYER_EXE) $(TEST_BE_EXE) + + +# command to run one test +ifeq (${OS}, Windows_NT) +# lookup where test/config.sh says wlimit is +WLIMIT:=$(shell bash -c 'source $(TST)/config.sh; which wlimit.exe') +RUNCMD=\ + ${WLIMIT} /q /w $(TIMEOUT) /m $(MEMOUT) $(TEST_BE_EXE) -st $(ARG) $(notdir $*).sil \ + &> $(notdir $*).slayer.out +COPY_EXES=copy_exes +else +RUNCMD=\ + ((ulimit -t $(TIMEOUT) -v $$(( $(MEMOUT) * 1024 )); \ + $(SLAYER_EXE) -st $(ARG) $(notdir $*).sil) \ + &> $(notdir $*).slayer.out) +COPY_EXES= +endif + + +# compile c to sil +%.sil : %.c $(FRONTEND_EXE) + @echo $*.c + -@bash -c ' \ + source $(TST)/config.sh; \ + cd $(dir $*); \ + $(TEST_FE_EXE) $(ARG) $(notdir $*).c &> $(notdir $*).slayer.out ' + +# Specific rules for compiling all c files in a test dir to sil +multi/link/link.sil : $(wildcard $(dir $@)/*.c) $(wildcard $(dir $@)/*.h) $(FRONTEND_EXE) + @echo $(dir $@) + -@bash -c ' \ + source $(TST)/config.sh; \ + cd $(dir $@); \ + $(TEST_FE_EXE) $(ARG) *.c &> $(basename $(notdir $@)).slayer.out' + +kmdf/toaster/%.sil : $(wildcard $(dir $@)/*.c) $(wildcard $(dir $@)/*.h) $(FRONTEND_EXE) + @echo $(dir $@) + -@bash -c ' \ + source $(TST)/config.sh; \ + INCLUDE="$(SL_INCLUDE_TOASTER);$$INCLUDE"; \ + cd $(dir $@); \ + $(TEST_FE_EXE) $(ARG) *.c &> $(basename $(notdir $@)).slayer.out' + +kmdf/pci_drv/pci_drv.sil : $(wildcard $(dir $@)/*.c) $(wildcard $(dir $@)/*.h) $(FRONTEND_EXE) + @echo $(dir $@) + -@bash -c ' \ + source $(TST)/config.sh; \ + INCLUDE="$(SL_INCLUDE_PCIDRV);$$INCLUDE"; \ + cd $(dir $@); \ + $(TEST_FE_EXE) $(ARG) *.c &> $(basename $(notdir $@)).slayer.out' + + +# analyze sil +%.slayer.out : $(SLAYER_EXE) %.sil bin/gather_results$(EXE) + @echo $*.sil $(ARG) + @bin/gather_results$(EXE) $(TestSils) + -@bash -c ' \ + if test -e $*.sil; then \ + cd $(dir $*); \ + status=$$( $(RUNCMD) )$$?; \ + case $$status in \ + ( 0 | 1 | 2 | 235 ) ;; \ + ( 137 | 152 | 233 ) echo -e "RESULT: TIMEOUT" >> $(notdir $*).slayer.out ;; \ + ( 236 ) echo -e "RESULT: MEMOUT" >> $(notdir $*).slayer.out ;; \ + ( 139 ) echo -e "RESULT: CRASH" >> $(notdir $*).slayer.out ;; \ + ( * ) echo -e "RESULT: Error: "$$status >> $(notdir $*).slayer.out ;; \ + esac fi' + + +# compile all c to sil +compile: $(COPY_EXES) $(CompSils) + + +# gather results +define gather-results = +bin/gather_results$(EXE) $(TestSils) +dos2unix -q RESULT.curr.tsv +cp -p RESULT.curr.html RESULT.$(VER).html +cp -p RESULT.curr.tsv RESULT.$(VER).tsv +cp -p RESULT.curr.txt RESULT.$(VER).txt +endef + +# ...without running tests +result: bin/gather_results$(EXE) + $(gather-results) + + +# ...after running all tests +test: $(COPY_EXES) $(SlayerOuts) bin/gather_results$(EXE) + $(gather-results) + + +cleansil: + @rm -f $(CompSils) + + +# remove result files +cleanout: + @rm -f $(SlayerOuts) + @$(FIND) . -name "*.dot" -exec rm {} + + + +# remove result files for TIMEOUTs +cleanTO: + @$(FIND) . -name '*.slayer.out' -exec bash -c '$(GREP) -q TIMEOUT {} && rm {}' \; + +# remove result files for MEMOUTs +cleanMO: + @$(FIND) . -name '*.slayer.out' -exec bash -c '$(GREP) -q MEMOUT {} && rm {}' \; + +# remove result files for HIT LIMITs +cleanHL: + @$(FIND) * -name "*.slayer.out" -exec bash -c '$(GREP) -q LIMIT {} && rm {}' \; + + +# branch to test +BRANCH=src +SRC=../../$(BRANCH)/$(BUILD_DIR) + +.PHONY: prover_test +prover_test: + @echo ======= compiling and running Prover tests ======= + bash -c ' \ + cd prover ; \ + for tst in *.ml; do \ + BASE=`basename -s .ml $$tst`; \ + echo $$BASE; \ + ocamlopt.opt -I $(TST)/../tools/Z3/build/api/ml -I $(SRC) -I $(SRC)/UnitTests str.cmxa unix.cmxa z3.cmxa $(SRC)/contaminated/PolySet.cmx $(SRC)/Library.cmx $(SRC)/CLArgs.cmx $(SRC)/PrettyPrinting.cmx $(SRC)/Log.cmx $(SRC)/Variable.cmx $(SRC)/Type.cmx $(SRC)/Expression.cmx $(SRC)/Graph_sig.cmx $(SRC)/Graph.cmx $(SRC)/Substitution.cmx $(SRC)/Timer.cmx $(SRC)/Z3ContextTree.cmx $(SRC)/Pure.cmx $(SRC)/UnitTests/TestGen.cmx $(SRC)/SymbolicHeap.cmx $(SRC)/SIL.cmx $(SRC)/Interproc_sig.cmx $(SRC)/AbstractTransitionSystem.cmx $(SRC)/Discovery.cmx $(SRC)/HeapGraph.cmx $(SRC)/Unification.cmx $(SRC)/UnitTests/TestGenProver.cmx $(SRC)/Prover.cmx $(SRC)/Reachability.cmx $(SRC)/HeapAbstraction.cmx $(SRC)/Abstraction.cmx $(SRC)/Frame.cmx $(SRC)/Interproc.cmx $(SRC)/SymbolicExecution.cmx $(SRC)/Analysis.cmx $(SRC)/CounterExample.cmx $(SRC)/SIL_wf.cmx $(SRC)/Inline.cmx $(SRC)/Predicates.cmx $(SRC)/PredicateEval.cmx $(SRC)/slam/io/fileNames.cmx $(SRC)/slam/io/version.cmx $(SRC)/slam/io/lg.cmx $(SRC)/slam/io/io.cmx $(SRC)/slam/io/sAL.cm√√x $(SRC)/slam/util/util.cmx $(SRC)/slam/ir/error.cmx $(SRC)/slam/ir/ctype.cmx $(SRC)/slam/ir/loc.cmx $(SRC)/slam/ir/pExpr.cmx $(SRC)/slam/ir/arrayField.cmx $(SRC)/slam/ir/irUtil.cmx $(SRC)/slam/ir/nCFG.cmx $(SRC)/slam/util/counter.cmx $(SRC)/slam/ir/compilationUnit.cmx $(SRC)/frontend_slam.cmx $(SRC)/ReconstructSpecs.cmx $(SRC)/Statistics.cmx $$BASE.ml -o $$BASE.native; \ + ./$$BASE.native &> $$BASE.log; \ + res=$$?; \ + rm -f $$BASE.{cmi,cmx,native,o,obj}; \ + done \ + ' + @echo ======= gathering Prover test results ======= + @bin/gather_results$(EXE) -ext ml -r prover + + +unit: + @echo ======= running SLAyer stand-alone unit tests ======= + bash -c 'for ut in ../bin/*fail*.native; do \ + wlimit /q /w $(TIMEOUT) /m $(MEMOUT) $$ut \ + &> `basename $$ut`.log; \ + res=$$?; \ + echo $$ut returned $$res; \ + done' + + + +# Note: use $(OnlySils) here instead of .../driver.sil +clean: + @rm -rf _build bin + @mv kmdf/1394/driver/driver.sil kmdf/1394/driver/driver_sil 2>/dev/null; true + @$(FIND) -regex '.*/slam\.\(li\|db\|f\|fptr\|log\|newpa\|newpa\.dot\|pa\|pa\.dot\|dump/.*\|dump.irdump\)\|.*/slam_acfg\|.*/slam_entrypoints.txt\|.*/slam_watch_starts.txt\|.*/slamcl\.out\|.*/slamresult\.txt\|.*/slam_watch_pairs\.txt\|.*/unreachable_funs.txt\|.*/slamstats\.txt\|.*\.dot\|.*\.dot.pdf\|.*\.i\|.*\.i\.orig\|.*\.li\|.*\.sil\|slam\.log\|.*\.slayer\.out\|.*\.z3\|.*\.z3\.cpp\|.*\.obj\|.*\.tt\|.*\.t2\|.*/ERRORS\.txt\|.*/OUTPUT\.txt\|.*~\|.*/\(abs\|ent\|sub\|sat\|norm\)_.*\.ml\|\./[^Z]*/.*.smt\|.*\.rawcfgf' -delete + @mv kmdf/1394/driver/driver_sil kmdf/1394/driver/driver.sil 2>/dev/null; true + + +# print any variable for Makefile debugging +print-%: + @echo '$*=$($*)' diff --git a/test/README b/test/README new file mode 100644 index 0000000..023c0a2 --- /dev/null +++ b/test/README @@ -0,0 +1,50 @@ +Instructions for testing + +- To run tests with default settings + $ make test + +- To run tests in parallel + $ make -j 4 test + +- To compile tests and then analyze them in parallel + $ make compile; make -j 4 test + +- To use to run tests + $ make SLAYER_EXE= ... + +- To run tests in ... + $ make DIR=" ... " ... + +- To pass to slayer, execute 'slayer -h' for possible + $ make ARG= ... + +- To limit test time usage + $ make TIMEOUT= ... + +- To limit test memory usage + $ make MEMOUT= ... + +- To report the known incorrect results + $ make bugs + +- To report the difference between actual and expected results + $ make report + +- To remove result files, forcing tests to be rerun + $ make cleanout + +- To remove result files for tests that exceeded the time limit + $ make cleanTO + +- To remove result files for tests that exceeded the memory limit + $ make cleanMO + +- To remove result files for tests that exceeded the analysis limit (set with -limit) + $ make cleanHL + +- To remove .sil files, forcing tests to be recompiled (test.sil is rebuilt from test.c + only if either test.c or frontend.exe has changed) + $ make cleansil + +- To remove all generated files + $ make clean diff --git a/test/cex/csll/cyclic_list_unsafe.c b/test/cex/csll/cyclic_list_unsafe.c new file mode 100644 index 0000000..e73052f --- /dev/null +++ b/test/cex/csll/cyclic_list_unsafe.c @@ -0,0 +1,78 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +// non-empty circular lists + +/* implements a stack and a queue simultaneously using a circular list: + * + * rear |-> top_front * lseg(top_front, rear) + * + * - the rear of the queue is the node pointed to by rear + * - the top of the stack and the front of the queue + * are both the node pointed to by the tl of x + * - we keep a pointer r to the rear, and existentially quantify top_front + */ +#include "slayer.h" +#include "heap.h" + +// utility functions /////////////////////////////////////////////////////////// + +void print_clist(cell* x) /* x|->-,y * ls(y,x) */ { + cell* z = x; + printf_s("("); + do { + print_cell(z); + z = z->cdr; + } while(z != x ? printf_s(", "),1 : 0); + printf_s(",...)"); +} /* x|->-,y * ls(y,x) */ + + +// operations ////////////////////////////////////////////////////////////////// + +/* push */ +void insert_after(cell* x, int n) /* x|->-,y * ls(y,x) */ { + cell* t = new(); /* x|->-,y * t|->-,- * ls(y,x) */ + t->car = n; + t->cdr = x->cdr->cdr; /* x|->-,y * t|->n,y * ls(y,x) */ + x->cdr = t; +} /* x|->-,t * t|->n,y * ls(y,x) */ + +void rotate(cell* *x) /* x|->-,y * ls(y,x) */ { + *x = (*x)->cdr; /* ls(x,x') * x'|->-,x */ +} /* x|->-,z * ls(z,x) */ + +/* enqueue */ +void insert_before(cell* *x, int n) /* x|->-,y * ls(y,x) */ { + insert_after(*x, n); /* x|->-,t * t|->n,y * ls(y,x) */ + *x = (*x)->cdr; /* spec of rotate(x); too weak to use here */ +} /* x|->n,y * ls(y,x) */ + +/* pop / dequeue */ +/* this is the spec & proof for the possibly-empty list version */ +void delete_next(cell* x) /* x|->y * ls(y,x) */ { + cell* t = x->cdr; /* t=y | x=y ? x|->y : x|->y * y|->z * ls(z,x) */ + cell* u = t->cdr; /* t=y | x=y ? x|->y : u=z | x|->y * y|->z * ls(z,x) */ + x->cdr = u; /* x=y ? t|->u : x|->z * t|->z * ls(z,x)) */ + free(t); +} /* x=y ? emp : x|->z * ls(z,x) */ + + +// test harness //////////////////////////////////////////////////////////////// + +int main() { + cell* x; + x = new(); + x->car = 0; + // x->cdr = x; + printf_s("clist:\t\t"); print_clist(x); printf_s("\n"); + insert_after(x, 1); + insert_after(x, 2); + printf_s("push 1, 2:\t"); print_clist(x); printf_s("\n"); + insert_before(&x, 3); + insert_before(&x, 4); + printf_s("enqueue 3, 4:\t"); print_clist(x); printf_s("\n"); + delete_next(x); + printf_s("pop / dequeue:\t"); print_clist(x); printf_s("\n"); + rotate(&x); + printf_s("rotate:\t\t"); print_clist(x); printf_s("\n"); +} diff --git a/test/cex/csll/destroy_iter_rem_unsafe.c b/test/cex/csll/destroy_iter_rem_unsafe.c new file mode 100644 index 0000000..13c6c3c --- /dev/null +++ b/test/cex/csll/destroy_iter_rem_unsafe.c @@ -0,0 +1,32 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/** + Create and destroy a cyclic singly-linked list. + + Works by iteratively unlinking and freeing nodes from the list until it has + length one, then frees the remaining node. +**/ + +#include "sll.h" + + +void CSLL_destroy(PSLL_ENTRY head) { + PSLL_ENTRY curr, next; + curr = head->Flink; + while( head != curr ) { + free(curr); + next = curr->Flink; + head->Flink = next; + curr = next; + } + free(head); +} + + +void main() { + PSLL_ENTRY head, tail; + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + CSLL_destroy(head); +} diff --git a/test/cex/csll/destroy_test_dangling_unsafe.c b/test/cex/csll/destroy_test_dangling_unsafe.c new file mode 100644 index 0000000..94553fb --- /dev/null +++ b/test/cex/csll/destroy_test_dangling_unsafe.c @@ -0,0 +1,31 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/** + Create and destroy a cyclic singly-linked list. + + Works by freeing the first node, followed by all others until seeing a + pointer back to the first one. Since this performs a test against a + dangling pointer, it has unspecified behavior according to section 6.2.4.2 + of the ISO C99 standard. +**/ + +#include "sll.h" + + +void destroy(PSLL_ENTRY x) { + PSLL_ENTRY h = x, c; + do { + c = x; + x = x->Flink; + free(c); + } while(x != h); +} + + +void main() { + PSLL_ENTRY head, tail; + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + // tail->Flink = head; + destroy(head); +} diff --git a/test/cex/csll/fill_walk_drain_unsafe.c b/test/cex/csll/fill_walk_drain_unsafe.c new file mode 100644 index 0000000..3972e4c --- /dev/null +++ b/test/cex/csll/fill_walk_drain_unsafe.c @@ -0,0 +1,44 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + +PSLL_ENTRY newEntry() { return malloc(sizeof(SLL_ENTRY)); } + +void fill(PSLL_ENTRY head) { + while (nondet()) { + PSLL_ENTRY entry = newEntry(); + entry->Flink = head->Flink; + head->Flink = entry; + } +} + +void walk(PSLL_ENTRY head) { + PSLL_ENTRY entry = head->Flink; + while (entry != head) { + entry = entry->Flink; + } +} + +void drain(PSLL_ENTRY head) { + PSLL_ENTRY entry = head->Flink; + while (entry != head) { + PSLL_ENTRY next = entry->Flink; + free(entry); + entry = next; + } +} + +void main() { + PSLL_ENTRY head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink = head; + fill(head); + walk(head); + assert(head=NULL); + drain(head); + free(head); +} diff --git a/test/cex/csll/remove2_unsafe.c b/test/cex/csll/remove2_unsafe.c new file mode 100644 index 0000000..421dcdc --- /dev/null +++ b/test/cex/csll/remove2_unsafe.c @@ -0,0 +1,38 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* Similar to remove, but does not destroy the list. */ + +#include "../../csll/csll.h" + + +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + + prev = head; + entry = head->Flink; + while( entry != head ) { + if( entry->Data == fo ) { + /* remove entry */ + free(entry); + tmp = entry->Flink; + prev->Flink = tmp; + entry = tmp; + } else { + prev = entry; + entry = entry->Flink; + } + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + +/* CSLL_destroy(head); */ +} diff --git a/test/cex/csll/remove_for2_unsafe.c b/test/cex/csll/remove_for2_unsafe.c new file mode 100644 index 0000000..a3a3e41 --- /dev/null +++ b/test/cex/csll/remove_for2_unsafe.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* + Similar to remove2, but using a for loop. + */ + +#include "csll.h" + + +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + for( prev = head, entry = head->Flink; + entry != head; + prev = entry, entry = entry->Flink ) { + if( entry->Data == fo ) { + prev->Flink = tmp; + free(entry); + tmp = entry->Flink; + entry = prev; + } + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + + CSLL_destroy(head); +} diff --git a/test/cex/csll/remove_for_unsafe.c b/test/cex/csll/remove_for_unsafe.c new file mode 100644 index 0000000..1e9b692 --- /dev/null +++ b/test/cex/csll/remove_for_unsafe.c @@ -0,0 +1,34 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* + Similar to remove, but using a for loop. + */ +#include "csll.h" + + +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + for( prev = head, entry = head->Flink; + entry != head; + prev = entry, entry = entry->Flink ) { + if( entry->Data == fo ) { + free(entry); + tmp = entry->Flink; + prev->Flink = tmp; + entry = prev; + } + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + + CSLL_destroy(head); +} diff --git a/test/cex/csll/remove_unsafe.c b/test/cex/csll/remove_unsafe.c new file mode 100644 index 0000000..a124b25 --- /dev/null +++ b/test/cex/csll/remove_unsafe.c @@ -0,0 +1,47 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY find(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + + prev = head; + entry = head->Flink; + while(entry != head) { + if (entry->Data == fo) { + /* remove entry */ + tmp = entry->Flink; + prev->Flink = tmp; + if (nondet()) { + return entry; + } else { + free(entry); + } + } else { + prev = entry; + } + entry = entry->Flink; + } + + return NULL; +} + +void main() { + PSLL_ENTRY head, tail, mark; + int i; + PSLL_ENTRY tmp; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + + head = tail; + for(i = 0; i < 4; i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + tail->Flink = head; + + find(head, 42); + +} diff --git a/test/cex/kmdf/CromData_trace_unsafe.c b/test/cex/kmdf/CromData_trace_unsafe.c new file mode 100644 index 0000000..189c0ab --- /dev/null +++ b/test/cex/kmdf/CromData_trace_unsafe.c @@ -0,0 +1,1242 @@ +/****************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + t1394_SetLocalHostProperties procedure. + + ******************************************************************************/ + +#include "harness.h" +#include "1394.h" + +NTSTATUS t1394_SubmitIrpSynch(WDFIOTARGET IoTarget, WDFREQUEST Request, PIRB Irb) +{ + int x; + if (x) { + return STATUS_SUCCESS; + } else { + return STATUS_UNSUCCESSFUL; + } +} + +NTSTATUS +t1394_SetLocalHostProperties( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDFREQUEST Request, + /*IN*/ ULONG nLevel, + /*IN*/ PVOID Information + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension = GetDeviceContext(Device); + PIRB pIrb = NULL; + PSET_LOCAL_HOST_PROPS3 R0_SetLocalHostProps3 = NULL; + PCROM_DATA CromData = NULL; + PLIST_ENTRY listHead, thisEntry; + + //ENTER("t1394_SetLocalHostProperties"); + + // allocate irb + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + if (!pIrb) { + + // TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } // if + + + + RtlZeroMemory (pIrb, sizeof (IRB)); + pIrb->FunctionNumber = REQUEST_SET_LOCAL_HOST_PROPERTIES; + pIrb->Flags = 0; + pIrb->u.SetLocalHostProperties.nLevel = nLevel; + + // TRACE(TL_TRACE, ("nLevel = 0x%x\n", nLevel)); + // TRACE(TL_TRACE, ("Information = 0x%x\n", Information)); + + if (nLevel == SET_LOCAL_HOST_PROPERTIES_GAP_COUNT) { + + PSET_LOCAL_HOST_PROPS2 SetLocalHostProps2; + + SetLocalHostProps2 = (PSET_LOCAL_HOST_PROPS2)Information; + + // TRACE(TL_TRACE, ("GapCountLowerBound = 0x%x\n", SetLocalHostProps2->GapCountLowerBound)); + + pIrb->u.SetLocalHostProperties.Information = Information; + } + else if (nLevel == SET_LOCAL_HOST_PROPERTIES_MODIFY_CROM) { + + PSET_LOCAL_HOST_PROPS3 SetLocalHostProps3; + + SetLocalHostProps3 = (PSET_LOCAL_HOST_PROPS3)Information; + + // TRACE(TL_TRACE, ("fulFlags = 0x%x\n", SetLocalHostProps3->fulFlags)); + // TRACE(TL_TRACE, ("hCromData = 0x%x\n", SetLocalHostProps3->hCromData)); + // TRACE(TL_TRACE, ("nLength = 0x%x\n", SetLocalHostProps3->nLength)); + + // since we need to create a mdl, we'll create another setlocalhostprops3 + // and pass that down to the bus driver + R0_SetLocalHostProps3 = ExAllocatePoolWithTag(NonPagedPool, + sizeof(SET_LOCAL_HOST_PROPS3), + POOLTAG_1394); + + if (!R0_SetLocalHostProps3) { + + // TRACE(TL_ERROR, ("Failed to allocate R0_SetLocalHostProps3!\n")); + if (pIrb) + ExFreePool(pIrb); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } // if + + // TRACE(TL_TRACE, ("R0_SetLocalHostProps3 = 0x%x\n", R0_SetLocalHostProps3)); + + // copy over the contents... + RtlCopyMemory( R0_SetLocalHostProps3, + SetLocalHostProps3, + sizeof(SET_LOCAL_HOST_PROPS3) + ); + + // branch, depending if we are adding or removing + if (R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_ADD_CROM_DATA) { + + // we are adding an entry. let's get our crom data struct... + CromData = ExAllocatePoolWithTag(NonPagedPool, + sizeof(CROM_DATA), + POOLTAG_1394); + + if (!CromData) { + + // TRACE(TL_ERROR, ("Failed to allocate CromData!\n")); + if (pIrb) + ExFreePool(pIrb); + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } + + // let's allocate our buffer... + CromData->Buffer = ExAllocatePoolWithTag(NonPagedPool, + R0_SetLocalHostProps3->nLength, + POOLTAG_1394); + + // TRACE(TL_TRACE, ("CromData->Buffer = 0x%x\n", CromData->Buffer)); + + if (!CromData->Buffer) { + + // TRACE(TL_ERROR, ("Failed to allocate CromData->Buffer!\n")); + if (pIrb) + ExFreePool(pIrb); + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + + if (CromData) + ExFreePool(CromData); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } + + // copy over contents (mdl == ring 3 buffer) + RtlCopyMemory(CromData->Buffer, + &SetLocalHostProps3->Mdl, + SetLocalHostProps3->nLength); + + R0_SetLocalHostProps3->Mdl = IoAllocateMdl (CromData->Buffer, + R0_SetLocalHostProps3->nLength, + FALSE, + FALSE, + NULL); + if(R0_SetLocalHostProps3->Mdl == NULL) { + + // TRACE(TL_ERROR, ("Failed to allocate mdl for CromData->Buffer!\n")); + if (pIrb) + ExFreePool(pIrb); + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + + if (CromData) + ExFreePool(CromData); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + + } + MmBuildMdlForNonPagedPool(R0_SetLocalHostProps3->Mdl); + + // TRACE(TL_TRACE, ("Mdl = 0x%x\n", R0_SetLocalHostProps3->Mdl)); + } + else if (SetLocalHostProps3->fulFlags == SLHP_FLAG_REMOVE_CROM_DATA) { + + // TRACE(TL_TRACE, ("hCromData = 0x%x\n", R0_SetLocalHostProps3->hCromData)); + } + + pIrb->u.SetLocalHostProperties.Information = (PVOID)R0_SetLocalHostProps3; + } + + ntStatus = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, Request, pIrb); + + if (!NT_SUCCESS(ntStatus)) { + + if (nLevel == SET_LOCAL_HOST_PROPERTIES_MODIFY_CROM) { + + if (R0_SetLocalHostProps3 && + R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_ADD_CROM_DATA) { + + if (R0_SetLocalHostProps3->Mdl) + IoFreeMdl(R0_SetLocalHostProps3->Mdl); + + if (CromData) { + if (CromData->Buffer) { + ExFreePool(CromData->Buffer); + } + ExFreePool(CromData); + } + } + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + } + + // TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", ntStatus)); + } + else { + + if (nLevel == SET_LOCAL_HOST_PROPERTIES_MODIFY_CROM) { + // + // branch, depending if we are adding or removing + // + if (R0_SetLocalHostProps3 && + R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_ADD_CROM_DATA) { + + PSET_LOCAL_HOST_PROPS3 SetLocalHostProps3; + + SetLocalHostProps3 = Information; + SetLocalHostProps3->hCromData = R0_SetLocalHostProps3->hCromData; + + // TRACE(TL_TRACE, ("hCromData = 0x%x\n", SetLocalHostProps3->hCromData)); + + if (CromData) { + + CromData->hCromData = SetLocalHostProps3->hCromData; + CromData->pMdl = R0_SetLocalHostProps3->Mdl; + + // need to add to our list... + + WdfSpinLockAcquire(deviceExtension->CromSpinLock); + InsertHeadList(&deviceExtension->CromData, &CromData->CromList); + + WdfSpinLockRelease(deviceExtension->CromSpinLock); + } + } + else if (R0_SetLocalHostProps3 && + R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_REMOVE_CROM_DATA) { + + // have to find our struct... + + WdfSpinLockAcquire(deviceExtension->CromSpinLock); + + listHead = &deviceExtension->CromData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + CromData = NULL, thisEntry = thisEntry->Flink) + { + CromData = CONTAINING_RECORD(thisEntry, CROM_DATA, CromList); + if (CromData->hCromData == R0_SetLocalHostProps3->hCromData) { + RemoveEntryList(&CromData->CromList); + break; + } + } + + WdfSpinLockRelease(deviceExtension->CromSpinLock); + + if (CromData) { + + if (CromData->Buffer) + ExFreePool(CromData->Buffer); + + if (CromData->pMdl) + IoFreeMdl(CromData->pMdl); + + ExFreePool(CromData); + } + } + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + } + } + + +Exit_SetLocalHostProperties: + + if (pIrb) + { + ExFreePool(pIrb); + } + + + //EXIT("t1394_SetLocalHostProperties", ntStatus); + return(ntStatus); +} // t1394_SetLocalHostProperties + + +/****************************************************************************** + + WDF_IO_QUEUE_IO_DEVICE_CONTROL + + The IOCTL_SET_LOCAL_HOST_INFORMATION part of EvtIoDeviceControl. + Tranform the Request into a SetLocalHostInformation, and pass it down to + the local t1394_SetLocalHostProperties procedure. + + ******************************************************************************/ +VOID +t1394_EvtIoDeviceControl( + /*IN*/WDFQUEUE Queue, + /*IN*/WDFREQUEST Request, + /*IN*/size_t OutputBufferLength, + /*IN*/size_t InputBufferLength, + /*IN*/ULONG IoControlCode + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension; + PVOID ioBuffer = NULL; + WDFDEVICE device; + size_t bufLength; + + //ENTER("t1394_EvtIoDeviceControl"); + // TRACE(TL_TRACE, ("Request = 0x%p\n", Request)); + + device = WdfIoQueueGetDevice(Queue); + deviceExtension = GetDeviceContext(device); + + // + // Since all the IOCTLs handled here are buffered, WdfRequestRetrieveOutputBuffer & + // WdfRequestRetrieveInputBuffer return the same buffer pointer. + // So make sure you read all the information you need from + // the buffer before you write to it. Also requiredLength of the buffer vary from + // ioctl to ioctl, so we will pretend that we need zero length buffer and do the lenght + // check later in the specific ioct case. + // + ntStatus = WdfRequestRetrieveInputBuffer(Request, 0, &ioBuffer, &bufLength); + if( !NT_SUCCESS(ntStatus) || ioBuffer == NULL) { + // TRACE(TL_ERROR, ("WdfRequestRetrieveInputBuffer failed 0x%x\n", ntStatus)); + WdfRequestComplete(Request, ntStatus); + return; + } + + + switch (IoControlCode) { + + case IOCTL_SET_LOCAL_HOST_INFORMATION: + { + PSET_LOCAL_HOST_INFORMATION SetLocalHostInformation; + + // TRACE(TL_TRACE, ("IOCTL_SET_LOCAL_HOST_INFORMATION\n")); + + if (InputBufferLength < sizeof(SET_LOCAL_HOST_INFORMATION)) { + + ntStatus = STATUS_BUFFER_TOO_SMALL; + } + else { + + SetLocalHostInformation = (PSET_LOCAL_HOST_INFORMATION)ioBuffer; + + if (InputBufferLength < (sizeof(SET_LOCAL_HOST_INFORMATION) + + SetLocalHostInformation->ulBufferSize)) { + + ntStatus = STATUS_BUFFER_TOO_SMALL; + } + else { + + ntStatus = t1394_SetLocalHostProperties( device, + Request, + SetLocalHostInformation->nLevel, + (PVOID)&SetLocalHostInformation->Information + ); + + if (NT_SUCCESS(ntStatus)) + WdfRequestSetInformation(Request, OutputBufferLength); + } + } + } + break; // IOCTL_SET_LOCAL_HOST_INFORMATION + + default: + // TRACE(TL_ERROR, ("Invalid ioControlCode = 0x%x\n", IoControlCode)); + ntStatus = STATUS_INVALID_PARAMETER; + break; // default + + } // switch + + + // only complete if the device is there + if (ntStatus != STATUS_PENDING) { + + WdfRequestComplete(Request, ntStatus); + } + + //EXIT("t1394_IoControl", ntStatus); + return ; +} // t1394_EvtIoDeviceControl + + +/****************************************************************************** + + WDF_DEVICE_SEFL_MANAGED_IO_CLEANUP + (Only the CromData cleanup part of it) + + ******************************************************************************/ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( + /*IN*/ WDFDEVICE Device + ) +/*++ + +Routine Description: + + EvtDeviceSelfManagedIoCleanup is called by the Framework when the device is + being torn down, either in response to IRP_MN_REMOVE_DEVICE or + IRP_MN_SURPRISE_REMOVE_DEVICE. It will be called only once. Its job is to + stop all outstanding I/O in the driver that the Framework is not managing. + +Arguments: + + Device - Handle to a framework device object. + +Return Value: + + None + +--*/ +{ + PDEVICE_EXTENSION deviceExtension; + PLIST_ENTRY listEntry; + + //ENTER("t1394_PnpRemoveDevice"); + + deviceExtension = GetDeviceContext(Device); + + // TRACE(TL_WARNING, ("Removing 1394VDEV.SYS.\n")); + + // lets free up any crom data structs we've allocated... + + WdfSpinLockAcquire(deviceExtension->CromSpinLock); + + while (!IsListEmpty(&deviceExtension->CromData)) { + + PCROM_DATA CromData; + + // get struct off list + + listEntry = RemoveHeadList(&deviceExtension->CromData); + CromData = CONTAINING_RECORD(listEntry, CROM_DATA, CromList); + + // need to free up everything associated with this allocate... + if (CromData) + { + if (CromData->Buffer) { + ExFreePool(CromData->Buffer); + } + if (CromData->pMdl) { + IoFreeMdl(CromData->pMdl); + } + // we already checked CromData + ExFreePool(CromData); + } + } + + + WdfSpinLockRelease(deviceExtension->CromSpinLock); + +/* // lets free up any allocated addresses and deallocate all */ +/* // memory associated with them... */ + +/* WdfSpinLockAcquire(deviceExtension->AsyncSpinLock); */ + +/* while (!IsListEmpty(&deviceExtension->AsyncAddressData)) { */ + +/* PASYNC_ADDRESS_DATA AsyncAddressData; */ + +/* // get struct off list */ +/* listEntry = RemoveHeadList(&deviceExtension->AsyncAddressData); */ + +/* AsyncAddressData = CONTAINING_RECORD(listEntry, ASYNC_ADDRESS_DATA, */ +/* AsyncAddressList); */ + +/* // need to free up everything associated with this allocate... */ +/* if (AsyncAddressData->pMdl) */ +/* IoFreeMdl(AsyncAddressData->pMdl); */ + +/* if (AsyncAddressData->Buffer) */ +/* ExFreePool(AsyncAddressData->Buffer); */ + +/* if (AsyncAddressData->AddressRange) */ +/* ExFreePool(AsyncAddressData->AddressRange); */ + +/* if (AsyncAddressData) */ +/* ExFreePool(AsyncAddressData); */ +/* } */ + + +/* WdfSpinLockRelease(deviceExtension->AsyncSpinLock); */ + +/* // */ +/* // Free up any attached isoch buffers */ +/* // Note: There are known bugs in this code path */ +/* // */ +/* WHILE (TRUE) { */ + +/* WdfSpinLockAcquire(deviceExtension->IsochSpinLock); */ + +/* if (!IsListEmpty(&deviceExtension->IsochDetachData)) { */ + +/* PISOCH_DETACH_DATA IsochDetachData; */ + +/* IsochDetachData = (PISOCH_DETACH_DATA) */ +/* RemoveHeadList(&deviceExtension->IsochDetachData); */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: IsochDetachData = 0x%x\n", */ +/* IsochDetachData)); */ + +/* KeCancelTimer(&IsochDetachData->Timer); */ + +/* WdfSpinLockRelease(deviceExtension->IsochSpinLock); */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: IsochDetachData->Irp = 0x%x\n", */ +/* IsochDetachData->Request)); */ + +/* // need to save the status of the attach */ +/* // we'll clean up in the same spot for success's and timeout's */ +/* IsochDetachData->AttachStatus = STATUS_SUCCESS; */ + +/* // detach no matter what... */ +/* IsochDetachData->bDetach = TRUE; */ + +/* t1394_IsochCleanup(IsochDetachData); */ +/* } */ +/* else { */ + +/* WdfSpinLockRelease(deviceExtension->IsochSpinLock); */ +/* break; */ +/* } */ +/* } */ + +/* // */ +/* // Remove any isoch resource data */ +/* // */ +/* WHILE (TRUE) { */ + +/* WdfSpinLockAcquire(deviceExtension->IsochResourceSpinLock); */ + +/* if (!IsListEmpty(&deviceExtension->IsochResourceData)) { */ + +/* PISOCH_RESOURCE_DATA IsochResourceData = NULL; */ + +/* listEntry = RemoveHeadList(&deviceExtension->CromData); */ + +/* IsochResourceData = CONTAINING_RECORD(listEntry, */ +/* ISOCH_RESOURCE_DATA, */ +/* IsochResourceList); */ + +/* WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: IsochResourceData = 0x%x\n", */ +/* IsochResourceData)); */ + +/* if (IsochResourceData) { */ + +/* PIRB pIrb; */ +/* WDFREQUEST request; */ +/* NTSTATUS status; */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: Freeing hResource = 0x%x\n", */ +/* IsochResourceData->hResource)); */ + +/* status = WdfRequestCreate( */ +/* WDF_NO_OBJECT_ATTRIBUTES, */ +/* deviceExtension->StackIoTarget, */ +/* &request); */ + +/* if (!NT_SUCCESS(status)) { */ +/* // TRACE(TL_ERROR, ("Failed to allocate request %x\n", status)); */ +/* } */ +/* else { */ + +/* pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); */ + +/* if (!pIrb) { */ + +/* WdfObjectDelete(request); */ + +/* // TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ +/* } */ +/* else { */ + +/* RtlZeroMemory (pIrb, sizeof (IRB)); */ +/* pIrb->FunctionNumber = REQUEST_ISOCH_FREE_RESOURCES; */ +/* pIrb->Flags = 0; */ +/* pIrb->u.IsochFreeResources.hResource = IsochResourceData->hResource; */ + +/* status = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, request, pIrb); */ + +/* if (!NT_SUCCESS(status)) { */ + +/* // TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", status)); */ +/* } */ + +/* ExFreePool(pIrb); */ +/* WdfObjectDelete(request); */ +/* } */ +/* } */ +/* } */ +/* } */ +/* else { */ + + +/* WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); */ +/* break; */ +/* } */ +/* } */ + + //EXIT("t1394_PnpRemoveDevice", STATUS_SUCCESS); + +} // t1394_PnpRemoveDevice + + + +/****************************************************************************** + + WDF_DRIVER_DEVICE_ADD + + ******************************************************************************/ + + +NTSTATUS +t1394_EvtPrepareHardware ( + WDFDEVICE Device, + WDFCMRESLIST Resources, + WDFCMRESLIST ResourcesTranslated + ) +/*++ + +Routine Description: + + EvtDeviceStart event callback performs operations that are necessary + to make the driver's device operational. The framework calls the driver's + EvtDeviceStart callback when the PnP manager sends an IRP_MN_START_DEVICE + request to the driver stack. + +Arguments: + + Device - Handle to a framework device object. + +Return Value: + + WDF status code + +--*/ +{ + NTSTATUS status = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension; + +/* UNREFERENCED_PARAMETER(Resources); */ +/* UNREFERENCED_PARAMETER(ResourcesTranslated); */ + +/* VERIFY_IS_IRQL_PASSIVE_LEVEL(); */ + +/* TRACE(TL_TRACE, ( "--> t1394_EvtPrepareHardware\n")); */ + +/* deviceExtension = GetDeviceContext(Device); */ + +/* status = t1394_BusResetNotification( Device, */ +/* NULL, */ +/* REGISTER_NOTIFICATION_ROUTINE ); */ + +/* TRACE(TL_TRACE, ( "<-- t1394_EvtPrepareHardware\n")); */ + + return status; +} + +NTSTATUS +t1394_EvtReleaseHardware( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDFCMRESLIST ResourcesTranslated + ) +/*++ + +Routine Description: + + EvtDeviceReleaseHardware is called by the framework whenever the PnP manager + is revoking ownership of our resources. This may be in response to either + IRP_MN_STOP_DEVICE or IRP_MN_REMOVE_DEVICE. The callback is made before + passing down the IRP to the lower driver. + + In this callback, do anything necessary to free those resources. + +Arguments: + + Device - Handle to a framework device object. + +Return Value: + + NTSTATUS - Failures will be logged, but not acted on. + +--*/ +{ + NTSTATUS status; + +/* UNREFERENCED_PARAMETER(ResourcesTranslated); */ + +/* VERIFY_IS_IRQL_PASSIVE_LEVEL(); */ + +/* TRACE(TL_TRACE, ( "--> t1394_EvtReleaseHardware\n")); */ + +/* status = t1394_BusResetNotification(Device, */ +/* NULL, */ +/* DEREGISTER_NOTIFICATION_ROUTINE ); */ + +/* TRACE(TL_TRACE, ( "<-- t1394_EvtReleaseHardware\n")); */ + + return status; +} + +NTSTATUS +t1394_EvtDeviceD0Entry( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDF_POWER_DEVICE_STATE PreviousState + ) +/*++ + +Routine Description: + + EvtDeviceD0Entry event callback must perform any operations that are + necessary before the specified device is used. It will be called every + time the hardware needs to be (re-)initialized. This includes after + IRP_MN_START_DEVICE, IRP_MN_CANCEL_STOP_DEVICE, IRP_MN_CANCEL_REMOVE_DEVICE, + IRP_MN_SET_POWER-D0. + + This function runs at PASSIVE_LEVEL, though it is generally not paged. A + driver can optionally make this function pageable if DO_POWER_PAGABLE is set. + + Even if DO_POWER_PAGABLE isn't set, this function still runs at + PASSIVE_LEVEL. In this case, though, the function absolutely must not do + anything that will cause a page fault. + +Arguments: + + Device - Handle to a framework device object. + + PreviousState - Device power state which the device was in most recently. + If the device is being newly started, this will be + PowerDeviceUnspecified. + +Return Value: + + NTSTATUS + +--*/ +{ + NTSTATUS status = STATUS_SUCCESS; + +/* UNREFERENCED_PARAMETER(PreviousState); */ + +/* TRACE(TL_TRACE, ( */ +/* "-->t1394_EvtDeviceD0Entry - coming from %s\n", */ +/* DbgDevicePowerString(PreviousState))); */ + +/* // update the generation count */ +/* t1394_UpdateGenerationCount(Device); */ + +/* TRACE(TL_TRACE, ( "<--t1394_EvtDeviceD0Entry\n")); */ + + return status; +} + + +NTSTATUS +t1394_EvtDeviceD0Exit( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDF_POWER_DEVICE_STATE TargetState + ) +/*++ + +Routine Description: + + EvtDeviceD0Exit event callback must perform any operations that are + necessary before the specified device is moved out of the D0 state. If the + driver needs to save hardware state before the device is powered down, then + that should be done here. + + This function runs at PASSIVE_LEVEL, though it is generally not paged. A + driver can optionally make this function pageable if DO_POWER_PAGABLE is set. + + Even if DO_POWER_PAGABLE isn't set, this function still runs at + PASSIVE_LEVEL. In this case, though, the function absolutely must not do + anything that will cause a page fault. + +Arguments: + + Device - Handle to a framework device object. + + TargetState - Device power state which the device will be put in once this + callback is complete. + +Return Value: + + NTSTATUS + +--*/ +{ + +/* UNREFERENCED_PARAMETER(Device); */ +/* UNREFERENCED_PARAMETER(TargetState); */ + +/* TRACE(TL_TRACE, ( */ +/* "-->t1394_EvtDeviceD0Exit - moving to %s\n", */ +/* DbgDevicePowerString(TargetState))); */ + + +/* TRACE(TL_TRACE, ( "<--t1394_EvtDeviceD0Exit\n")); */ + + return STATUS_SUCCESS; +} + + +NTSTATUS +t1394_EvtDeviceAdd( + /*IN*/WDFDRIVER Driver, + /*IN*/PWDFDEVICE_INIT DeviceInit + ) +/*++ +Routine Description: + + EvtDeviceAdd is called by the framework in response to AddDevice + call from the PnP manager. + +Arguments: + + Driver - Handle to a framework driver object created in DriverEntry + + DeviceInit - Pointer to a framework-allocated WDFDEVICE_INIT structure. + +Return Value: + + NTSTATUS + +--*/ +{ + NTSTATUS status = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension; + PNODE_DEVICE_EXTENSION pNodeExt; + WDF_PNPPOWER_EVENT_CALLBACKS pnpPowerCallbacks; + WDF_OBJECT_ATTRIBUTES fdoAttributes,lockAttributes; + WDFDEVICE device; + WDF_DEVICE_PNP_CAPABILITIES pnpCaps; + WDF_IO_QUEUE_CONFIG ioQueueConfig; + WDF_IO_TARGET_OPEN_PARAMS openParams; + + //UNREFERENCED_PARAMETER(Driver); + + //ENTER("t1394_PnpAddDevice"); + + // + // Zero out the PnpPowerCallbacks structure. + // + WDF_PNPPOWER_EVENT_CALLBACKS_INIT(&pnpPowerCallbacks); + + // + // Set Callbacks for any of the functions we are interested in. + // If no callback is set, Framework will take the default action + // by itself. + + // + // These two callbacks set up and tear down hardware state, + // specifically that which only has to be done once. + // + + pnpPowerCallbacks.EvtDevicePrepareHardware = t1394_EvtPrepareHardware; + pnpPowerCallbacks.EvtDeviceReleaseHardware = t1394_EvtReleaseHardware; + + pnpPowerCallbacks.EvtDeviceSelfManagedIoCleanup = + t1394_EvtDeviceSelfManagedIoCleanup; + + pnpPowerCallbacks.EvtDeviceD0Entry = t1394_EvtDeviceD0Entry; + pnpPowerCallbacks.EvtDeviceD0Exit = t1394_EvtDeviceD0Exit; + + // + // Register the PnP and power callbacks. Power policy related callbacks + // will be registered// later in SotwareInit. + // + WdfDeviceInitSetPnpPowerEventCallbacks(DeviceInit, &pnpPowerCallbacks); + if ( !NT_SUCCESS(status)) { + //TRACE(TL_ERROR, ("WdfDeviceInitSetPnpPowerEventCallbacks failed %x\n", + // status)); + return status; + } + + WdfDeviceInitSetExclusive(DeviceInit, FALSE); + + // + // Specify the size and type of device context. + // + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&fdoAttributes, DEVICE_EXTENSION); + + status = WdfDeviceCreate(&DeviceInit, &fdoAttributes, &device); + + if ( !NT_SUCCESS(status)) { + //TRACE(TL_ERROR, ("WdfDeviceInitialize failed %x\n", status)); + return status; + } + + + deviceExtension = GetDeviceContext (device); + deviceExtension->WdfDevice = device; + + //TRACE(TL_TRACE, ("PDO(0x%p) FDO(0x%p), Lower(0x%p) DevExt (0x%p)\n", + // WdfDeviceWdmGetPhysicalDevice (device), + // WdfDeviceWdmGetDeviceObject (device), + // WdfDeviceWdmGetAttachedDevice(device), + // deviceExtension)); + + // + // Tell the Framework that this device will need an interface so that + // application can interact with it. + // + + status = WdfDeviceCreateDeviceInterface( + device, +#if defined(_1394VDEV_DRIVER_) + (LPGUID) &GUID_1394VDEV, +#else + (LPGUID) &GUID_1394DIAG, +#endif + NULL + ); + + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfDeviceCreateDeviceInterface failed %x\n", status)); + return status; + } + + // + // Tell the framework to set the SurpriseRemovalOK in the DeviceCaps so + // that you don't get the popup in usermode (on Win2K) when you surprise + // remove the device. + // + WDF_DEVICE_PNP_CAPABILITIES_INIT(&pnpCaps); + pnpCaps.SurpriseRemovalOK = WdfTrue; + + WdfDeviceSetPnpCapabilities(device, &pnpCaps); + + // save the device object we created as our physical device object + deviceExtension->PhysicalDeviceObject = + WdfDeviceWdmGetPhysicalDevice (device); + + if (deviceExtension->PhysicalDeviceObject == NULL) { + //TRACE(TL_ERROR, ("WdfDeviceWdmGetPhysicalDevice: NULL DeviceObject\n")); + return STATUS_UNSUCCESSFUL; + } + + // + // This is our default IoTarget representing the deviceobject + // we are attached to. + // + deviceExtension->StackIoTarget = WdfDeviceGetIoTarget(device); + deviceExtension->StackDeviceObject = WdfDeviceWdmGetAttachedDevice(device); + + if (deviceExtension->StackDeviceObject == NULL) { + //TRACE(TL_ERROR, ("WdfDeviceWdmGetAttachedDevice: NULL DeviceObject\n")); + return STATUS_UNSUCCESSFUL; + } + + // Patch: this code is not in DDK 7600.16385.1 { + // + // Get the port device object from the passed in PhysicalDeviceObject + // created by the 1394 stack for us. + // Note: we can't use the top of the stack and get its device extension + // in case there is a filter driver between us and our PDO. + // + //pNodeExt = WdfDeviceWdmGetPhysicalDevice(device)->DeviceExtension; + //deviceExtension->PortDeviceObject = pNodeExt->PortDeviceObject; + // Patch: this code is not in DDK 7600.16385.1 } + + //TRACE(TL_TRACE, ("PortDeviceObject = 0x%x\n", + // deviceExtension->PortDeviceObject)); + + // + // Create a automanaged queue for dispatching ioctl requests. + // All other requests are automatically failed by the framework. + // By creating an automanaged queue we don't have to worry about + // PNP/Power synchronization. + // A default queue gets all the requests that are not + // configure-fowarded using WdfDeviceConfigureRequestDispatching. + // + WDF_IO_QUEUE_CONFIG_INIT_DEFAULT_QUEUE( + &ioQueueConfig, + WdfIoQueueDispatchParallel + ); + + ioQueueConfig.EvtIoDeviceControl = t1394_EvtIoDeviceControl; + + status = WdfIoQueueCreate( + deviceExtension->WdfDevice, + &ioQueueConfig, + WDF_NO_OBJECT_ATTRIBUTES, + &deviceExtension->IoctlQueue // queue handle + ); + + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfIoQueueCreate failed 0x%x\n", status)); + return status; + } + + // + // Create an additional queue to hold bus reset requests. + // + WDF_IO_QUEUE_CONFIG_INIT( + &ioQueueConfig, + WdfIoQueueDispatchManual + ); + + status = WdfIoQueueCreate ( + deviceExtension->WdfDevice, + &ioQueueConfig, + WDF_NO_OBJECT_ATTRIBUTES, + &deviceExtension->BusResetRequestsQueue + ); + + if(!NT_SUCCESS (status)){ + //TRACE(TL_ERROR, ("Error Creating Reset Request Queue 0x%x\n", + // status)); + return status; + } + + // + // Create another IoTarget representing PortDeviceObject so that + // we can send async requests in rawmode directly to the port device. + // + WDF_IO_TARGET_OPEN_PARAMS_INIT_EXISTING_DEVICE(&openParams, + pNodeExt->PortDeviceObject); + status = WdfIoTargetCreate(device, + WDF_NO_OBJECT_ATTRIBUTES, + &deviceExtension->PortDeviceIoTarget); + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfIoTargetCreate failed 0x%x\n", status)); + return status; + } + + status = WdfIoTargetOpen(deviceExtension->PortDeviceIoTarget, &openParams); + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfIoTargetCreate failed 0x%x\n", status)); + return status; + } + + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + // initialize the spinlock/list to store the bus reset irps... + + status = WdfSpinLockCreate(&lockAttributes,&deviceExtension->CromSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate CromSpinLock " + // "failed 0x%x\n", status)); + return status; + } + + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + + status = WdfSpinLockCreate(&lockAttributes, + &deviceExtension->AsyncSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate AsyncSpinLock " + // "failed 0x%x\n", status)); + return status; + } + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + + status = WdfSpinLockCreate(&lockAttributes, + &deviceExtension->IsochSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate IsochSpinLock " + // "failed 0x%x\n", status)); + return status; + } + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + + status = WdfSpinLockCreate(&lockAttributes, + &deviceExtension->IsochResourceSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate IsochResourceSpinLock " + // "failed 0x%x\n", status)); + return status; + } + InitializeListHead(&deviceExtension->CromData); + InitializeListHead(&deviceExtension->AsyncAddressData); + InitializeListHead(&deviceExtension->IsochDetachData); + InitializeListHead(&deviceExtension->IsochResourceData); + + //EXIT("t1394_PnpAddDevice", status); + + return(status); +} // t1394_PnpAddDevice + + +/****************************************************************************** + + DriverEntry + + ******************************************************************************/ + +NTSTATUS +DriverEntry( + /*IN*/PDRIVER_OBJECT DriverObject, + /*IN*/PUNICODE_STRING RegistryPath + ) +/*++ + +Routine Description: + + Installable driver initialization entry point. + This entry point is called directly by the I/O system. + +Arguments: + + DriverObject - pointer to the driver object + + RegistryPath - pointer to a unicode string representing the path, + to driver-specific key in the registry. + +Return Value: + + STATUS_SUCCESS if successful, + STATUS_UNSUCCESSFUL otherwise. + +--*/ +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + WDF_DRIVER_CONFIG config; + + //ENTER("DriverEntry"); + + // //TRACE(TL_TRACE, ("1394VDev Sample - Driver Framework Edition \n")); + // TRACE(TL_TRACE, ("Built %s %s\n", __DATE__, __TIME__)); + + // + // Initialize the Driver Config structure.. + // + WDF_DRIVER_CONFIG_INIT( + &config, + t1394_EvtDeviceAdd + ); + + // + // Create a WDFDRIVER object. + // + ntStatus = WdfDriverCreate( + DriverObject, + RegistryPath, + WDF_NO_OBJECT_ATTRIBUTES, + &config, + WDF_NO_HANDLE + ); + + if (!NT_SUCCESS(ntStatus)) { + // TRACE(TL_ERROR, ("WdfDriverCreate failed with status %x\n", ntStatus)); + } + + //EXIT("DriverEntry", ntStatus); + return(ntStatus); +} // DriverEntry + + + + + + + + +/****************************************************************************** + + main + + ******************************************************************************/ +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +void main() +{ + + // This is the OS Model + PDRIVER_OBJECT DriverObject; + WDFDEVICE Device; + PWDFDEVICE_INIT DeviceInit; + WDFQUEUE Queue; + WDFREQUEST Request; + ULONG IoControlCode; // symbolic + int InputBufferLength, OutputBufferLength; // symbolic + PUNICODE_STRING RegistryPath; // symbolic, genuinely don't care. + NTSTATUS status; + + // $Super$$main + status = SLAyer_harness_init() ; + + if (NT_SUCCESS(status)) { + // OSModel: call DriverEntry + DriverEntry(DriverObject,RegistryPath); + + // OSModel: Add N devices, for N=1. + t1394_EvtDeviceAdd(SL_Driver, DeviceInit); + + // OSModel: Make a queue. + Queue = (WDFQUEUE)malloc(sizeof(SLAyer_WDFOBJECT)); + Queue->typ = SLAyerWdfQueue; + Queue->typQueue.Device = SL_Device_one; + + // OSModel: Make a request. + Request = (WDFREQUEST)malloc(sizeof(SLAyer_WDFOBJECT)); + Request->typ = SLAyerWdfRequest; + Request->typRequest.InputBuffer = (void*)_SLAyer_malloc(1024); + + // OSModel: send request to 1393 Device, + // which can only do Request IOCTL_SET_LOCAL_HOST_INFORMATION. + t1394_EvtIoDeviceControl(Queue, Request, OutputBufferLength, InputBufferLength, IoControlCode); + + // t1394_EvtDeviceSelfManagedIoCleanup(Device); + + SLAyer_harness_teardown(); + } + + +} + diff --git a/test/cex/kmdf/allocate_resources_insert_head_list_unsafe.c b/test/cex/kmdf/allocate_resources_insert_head_list_unsafe.c new file mode 100644 index 0000000..6dc9193 --- /dev/null +++ b/test/cex/kmdf/allocate_resources_insert_head_list_unsafe.c @@ -0,0 +1,44 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: allocate_resources_insert_head_list. + Source: isochapi.c, line 223. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +NTSTATUS +t1394_IsochAllocateResources(PDEVICE_EXTENSION deviceExtension) +{ + PISOCH_RESOURCE_DATA IsochResourceData; + + // need to add to our list... + IsochResourceData = (PISOCH_RESOURCE_DATA)malloc(sizeof(ISOCH_RESOURCE_DATA)); + + { + InsertHeadList(&deviceExtension->IsochResourceData, + &IsochResourceData->IsochResourceList); + } + return STATUS_SUCCESS; + +} // t1394_IsochAllocateResources + +int main () +{ + PDEVICE_EXTENSION deviceExtension; + NTSTATUS ntStatus = STATUS_SUCCESS; + PLIST_ENTRY prd ; + + // 0. Initialize devExt. + // deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(PDEVICE_EXTENSION)); + InitializeListHead(&(deviceExtension->IsochResourceData)); + + ntStatus = t1394_IsochAllocateResources(deviceExtension); + ntStatus = t1394_IsochAllocateResources(deviceExtension); + ntStatus = t1394_IsochAllocateResources(deviceExtension); + ntStatus = t1394_IsochAllocateResources(deviceExtension); + + return ntStatus; +} + diff --git a/test/cex/kmdf/attach_buffer_insert_head_list_unsafe.c b/test/cex/kmdf/attach_buffer_insert_head_list_unsafe.c new file mode 100644 index 0000000..f39e4fb --- /dev/null +++ b/test/cex/kmdf/attach_buffer_insert_head_list_unsafe.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: attach_buffer_insert_head_list. + Source: isochapi.c, line 432. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + +NTSTATUS +t1394_IsochAttachBuffers(PDEVICE_EXTENSION deviceExtension) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + PISOCH_DETACH_DATA pIsochDetachData = NULL; + + pIsochDetachData = (PISOCH_DETACH_DATA)malloc(sizeof(ISOCH_DETACH_DATA)); + if (!pIsochDetachData) + { + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_IsochAttachBuffers; + } + pIsochDetachData->DeviceExtension = deviceExtension; + InitializeListHead(&pIsochDetachData->IsochDetachList); + InsertHeadList(&deviceExtension->IsochDetachData, + &pIsochDetachData->IsochDetachList); + + Exit_IsochAttachBuffers: + return(ntStatus); +} // t1394_IsochAttachBuffers + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + + PDEVICE_EXTENSION deviceExtension; + NTSTATUS ntStatus; + + // OS Model init + ntStatus = SLAyer_harness_init(); + + if (NT_SUCCESS(ntStatus)) { + + deviceExtension = GetDeviceContext(SL_Device_one); + + // Setup + InitializeListHead(&(deviceExtension->IsochDetachData)); + + while (nondet()) { + ntStatus = t1394_IsochAttachBuffers(deviceExtension); + assert(0==1); + } + + // Note: We currently leak: teardown here. + } + + return ntStatus; + +} diff --git a/test/cex/kmdf/cleanup_isochresourcedata_remove_head_list_unsafe.c b/test/cex/kmdf/cleanup_isochresourcedata_remove_head_list_unsafe.c new file mode 100644 index 0000000..a69a891 --- /dev/null +++ b/test/cex/kmdf/cleanup_isochresourcedata_remove_head_list_unsafe.c @@ -0,0 +1,138 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/***************************************************************************** + 1394 Feature: cleanup_isochresourcedata_remove_head_list_unsafe. + Expected Result: POSSIBLY UNSAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + +#define WHILE while +#define TRUE (1==1) + +NTSTATUS t1394_SubmitIrpSynch(WDFIOTARGET IoTarget, WDFREQUEST Request, PIRB Irb) +{ + int x; + if (x) { + return STATUS_SUCCESS; + } else { + return STATUS_UNSUCCESSFUL; + } +} + +/* Source: WDK/src_5239/kmdf/1394/pnp.c, line 634. */ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( +/* IN WDFDEVICE Device */ + PDEVICE_EXTENSION deviceExtension /* added for SLAyer */ + ) +{ + PLIST_ENTRY listEntry; + + // + // Remove any isoch resource data + // + WHILE (TRUE) { + + WdfSpinLockAcquire(deviceExtension->IsochResourceSpinLock); + + if (!IsListEmpty(&deviceExtension->IsochResourceData)) { + + PISOCH_RESOURCE_DATA IsochResourceData = NULL; + +/* SLAyer: memory unsafety in original code. Reported as Windows 8 Bug #59410. Fixed by Patrick Maninger 9/Aug/2010. */ + listEntry = RemoveHeadList(&deviceExtension->CromData); + + IsochResourceData = CONTAINING_RECORD(listEntry, + ISOCH_RESOURCE_DATA, + IsochResourceList); + + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + +/* TRACE(TL_TRACE, ("Surprise Removal: IsochResourceData = 0x%x\n", */ +/* IsochResourceData)); */ + + if (IsochResourceData) { + + PIRB pIrb; + WDFREQUEST request; + NTSTATUS status; + +/* TRACE(TL_TRACE, ("Surprise Removal: Freeing hResource = 0x%x\n", */ +/* IsochResourceData->hResource)); */ + + status = WdfRequestCreate( + WDF_NO_OBJECT_ATTRIBUTES, + deviceExtension->StackIoTarget, + &request); + + if (!NT_SUCCESS(status)) { +/* TRACE(TL_ERROR, ("Failed to allocate request %x\n", status)); */ + free(IsochResourceData); /* SLAyer: added */ + } + else { + + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + + if (!pIrb) { + + WdfObjectDelete(request); + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ + free(IsochResourceData); /* SLAyer: added */ + } + else { + + RtlZeroMemory (pIrb, sizeof (IRB)); + pIrb->FunctionNumber = REQUEST_ISOCH_FREE_RESOURCES; + pIrb->Flags = 0; + pIrb->u.IsochFreeResources.hResource = IsochResourceData->hResource; + + status = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, request, pIrb); + free(IsochResourceData); /* SLAyer: added */ + + if (!NT_SUCCESS(status)) { + +/* TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", status)); */ + } + + ExFreePool(pIrb); + WdfObjectDelete(request); + } + } + } + } + else { + + + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + break; + } + } + +/* EXIT("t1394_PnpRemoveDevice", STATUS_SUCCESS); */ + +} + + +NTSTATUS +main() +{ + DEVICE_EXTENSION devExt; + unsigned int count, i; // count=* + + InitializeListHead(&(devExt.IsochResourceData)); + + for (i=0; iIsochResourceList)); + } + + // 2. Delete all Isochresourcedatas. + t1394_EvtDeviceSelfManagedIoCleanup(&devExt); + + return STATUS_SUCCESS; +} + + diff --git a/test/cex/kmdf/cromdata_add_remove_unsafe.c b/test/cex/kmdf/cromdata_add_remove_unsafe.c new file mode 100644 index 0000000..13254a0 --- /dev/null +++ b/test/cex/kmdf/cromdata_add_remove_unsafe.c @@ -0,0 +1,61 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: 1394api_Add_and_Remove_CromData. + Source: 1394api.c::t1394_SetLocalHostProperties, lines 823-985, 959-991 + Expected Result: SAFE. +*****************************************************************************/ +#include "harness.h" +#include "1394.h" + +#define BUFFER_LENGTH 32 + +NTSTATUS +main() +{ + PDEVICE_EXTENSION deviceExtension; + PLIST_ENTRY listEntry; + + deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(PDEVICE_EXTENSION)); + InitializeListHead(&(deviceExtension->CromData)); + + // Add some CromDatas to deviceExtension. + while (nondet()) { + PCROM_DATA CromDataNew ; + CromDataNew = (PCROM_DATA) malloc(sizeof(CROM_DATA)); + CromDataNew->Buffer = (PVOID)malloc(sizeof(BUFFER_LENGTH)); + CromDataNew->pMdl = (PMDL)malloc(sizeof(MDL)); + InsertHeadList(&deviceExtension->CromData, &CromDataNew->CromList); + } + + // assert dE->CromData is a dll. + + // - Delete all CromDatas. + // pnp.c:: t1394_EvtDeviceSelfManagedIoCleanup, lines 531-556. + while (!IsListEmpty(&deviceExtension->CromData)) { + + PCROM_DATA CromData; + + // get struct off list + + listEntry = RemoveHeadList(&deviceExtension->CromData); + CromData = CONTAINING_RECORD(listEntry, CROM_DATA, CromList); + + // need to free up everything associated with this allocate... + if (CromData) + { + if (CromData->Buffer) + ExFreePool(CromData->Buffer); + + if (CromData->pMdl) + IoFreeMdl(CromData->pMdl); + + // we already checked CromData + ExFreePool(CromData); + } + } + + // Teardown ... Not implemented yet, will LEAK. + // free(deviceExtension); + return STATUS_SUCCESS; +} diff --git a/test/cex/kmdf/free_resources_remove_entry_list_unsafe.c b/test/cex/kmdf/free_resources_remove_entry_list_unsafe.c new file mode 100644 index 0000000..a5a6a7c --- /dev/null +++ b/test/cex/kmdf/free_resources_remove_entry_list_unsafe.c @@ -0,0 +1,153 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: free_resources_remove_entry_list. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 679. */ +NTSTATUS +t1394_IsochFreeResources( + PDEVICE_EXTENSION deviceExtension, /* added for SLAyer */ +/* IN WDFDEVICE Device, */ +/* IN WDFREQUEST Request, */ + /* IN */ HANDLE hResource + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; +/* PDEVICE_EXTENSION deviceExtension = GetDeviceContext(Device); */ + PIRB pIrb = NULL; + PISOCH_RESOURCE_DATA IsochResourceData = NULL; + PLIST_ENTRY listHead; + PLIST_ENTRY thisEntry; + +/* ENTER("t1394_IsochFreeResources"); */ + +/* TRACE(TL_TRACE, ("hResource = 0x%x\n", hResource)); */ + + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + + if (!pIrb) { + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_IsochFreeResources; + } // if + + // remove this one from our list... + + WdfSpinLockAcquire(deviceExtension->IsochResourceSpinLock); + + listHead = &deviceExtension->IsochResourceData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + IsochResourceData = NULL, thisEntry = thisEntry->Flink) + { + assert(thisEntry->Flink == NULL) ; + IsochResourceData = CONTAINING_RECORD(thisEntry, + ISOCH_RESOURCE_DATA, + IsochResourceList); + + if (IsochResourceData->hResource == hResource) { +/* TRACE(TL_TRACE, ("Removing hResource = 0x%x\n", hResource)); */ + RemoveEntryList(&IsochResourceData->IsochResourceList); + ExFreePool(IsochResourceData); + break; + } + } + + + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + + RtlZeroMemory (pIrb, sizeof (IRB)); +/* pIrb->FunctionNumber = REQUEST_ISOCH_FREE_RESOURCES; */ + pIrb->Flags = 0; +/* pIrb->u.IsochFreeResources.hResource = hResource; */ + +/* ntStatus = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, Request, pIrb); */ + + if (!NT_SUCCESS(ntStatus)) { + +/* TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", ntStatus)); */ + } + +Exit_IsochFreeResources: + + if (pIrb) + { + ExFreePool(pIrb); + } + +/* EXIT("t1394_IsochFreeResources", ntStatus); */ + return(ntStatus); +} // t1394_IsochFreeResources + + +/****************************************************************************** + + main + + ******************************************************************************/ + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + PDEVICE_EXTENSION devExt; + NTSTATUS ntStatus; + PISOCH_RESOURCE_DATA pird; + PISOCH_RESOURCE_DATA obj_to_del = NULL; + int choice; + unsigned int count, i; // count=* + + // OS Model init + ntStatus = SLAyer_harness_init(); + + if (NT_SUCCESS(ntStatus)) { + devExt = GetDeviceContext(SL_Device_one); + + InitializeListHead(&(devExt->IsochResourceData)); + + // Add some IsochResourceData off devExt. + // Set obj_to_del to one of these. + for (i=0; iIsochResourceData),&(pird->IsochResourceList)); + } + if (!obj_to_del) obj_to_del = pird; + + ntStatus = t1394_IsochFreeResources(devExt, obj_to_del); + + // Now set obj_to_del to something new. + obj_to_del = (PISOCH_RESOURCE_DATA)malloc(sizeof(ISOCH_RESOURCE_DATA)); + InitializeListHead(&(obj_to_del->IsochResourceList)); + + ntStatus = t1394_IsochFreeResources(devExt, obj_to_del); + } + + return ntStatus; +} + diff --git a/test/cex/kmdf/is_on_list_flat_unsafe.c b/test/cex/kmdf/is_on_list_flat_unsafe.c new file mode 100644 index 0000000..4ae313d --- /dev/null +++ b/test/cex/kmdf/is_on_list_flat_unsafe.c @@ -0,0 +1,62 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: t1394_IsOnList. + Source: util.c, line 60. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" + +BOOLEAN +t1394_IsOnList( + PLIST_ENTRY Entry, + PLIST_ENTRY List + ) +{ + PLIST_ENTRY TempEntry; + + for( + TempEntry = List->Flink; + TempEntry != List; + TempEntry = TempEntry->Flink + ) + { + if (TempEntry == Entry) + { + /* TRACE(TL_TRACE, ("Entry 0x%x found on list 0x%x\n", Entry, List)); */ + assert(TempEntry->Flink == NULL); + return TRUE; + } + } + + /* TRACE(TL_TRACE, ("Entry 0x%x not found on list 0x%x\n", Entry, List)); */ + return FALSE; +} + + +/* + * Harness. + */ +int main () +{ + int result; + int length, i; + PLIST_ENTRY entry, ll, tmp; + + // Create a list of some size; 'entry' is one of these elements. + ll = (PLIST_ENTRY) malloc (sizeof(LIST_ENTRY)) ; + InitializeListHead(ll); + entry = ll; + + for (i=0; iBuffer = (PVOID)malloc(sizeof(int)); + data_x->pMdl = (PMDL)malloc(sizeof(MDL)); + data_x->hCromData = &d_x; + data_y = (PCROM_DATA)malloc(sizeof(int)); + data_y->Buffer = (PVOID)malloc(sizeof(int)); + data_y->pMdl = (PMDL)malloc(1); + data_y->hCromData = &d_y; + data_z = (PCROM_DATA)malloc(sizeof(CROM_DATA)); + data_z->Buffer = (PVOID)malloc(sizeof(int)); + data_z->pMdl = (PMDL)malloc(sizeof(MDL)); + data_z->hCromData = &d_z; + +/* SL_triple_CromDatas(deviceExtension,data_x,data_y,data_z) ; */ + + InitializeListHead(&(deviceExtension->CromData)); + InitializeListHead(&(data_x->CromList)); + //InitializeListHead(&(data_y->CromList)); + InitializeListHead(&(data_z->CromList)); + + InsertHeadList(&deviceExtension->CromData, &data_x->CromList); + InsertHeadList(&deviceExtension->CromData, &data_y->CromList); + InsertHeadList(&deviceExtension->CromData, &data_z->CromList); + +/* SL_triple_CromDatasInserted(deviceExtension,data_x,data_y,data_z) ; */ + + // 2. Delete some CromDatas. + listHead = &deviceExtension->CromData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + thisEntry = thisEntry->Flink) + { + int *filter = &d_y; // Could leave un-initialized for a more generic test. + CROM_DATA *CromData = CONTAINING_RECORD(thisEntry, CROM_DATA, CromList); + if (CromData->hCromData == filter) { + RemoveEntryList(&CromData->CromList); + break; + } + } + + // Note: Teardown. Currently we LEAK. + return STATUS_SUCCESS; +} diff --git a/test/cex/simple/changing_truth_value_unsafe.c b/test/cex/simple/changing_truth_value_unsafe.c new file mode 100644 index 0000000..39d6537 --- /dev/null +++ b/test/cex/simple/changing_truth_value_unsafe.c @@ -0,0 +1,25 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Returns: POSSIBLY UNSAFE *\ +\* Exptected Return: Unsafe */ + +int main() +{ + int v = nondet() % 10; + int j; + int* i; + if(v) i = (int*)malloc(sizeof(int)); + + + for(j = 0; j < 4; j++) { + v += (nondet() % 4); + } + + if(v) { + *i = 0; + free(i); + } + return 0; +} diff --git a/test/cex/simple/changing_truth_value_unsafe_garbage.c b/test/cex/simple/changing_truth_value_unsafe_garbage.c new file mode 100644 index 0000000..bd43d18 --- /dev/null +++ b/test/cex/simple/changing_truth_value_unsafe_garbage.c @@ -0,0 +1,34 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Returns: POSSIBLY UNSAFE *\ +\* Exptected Return: Unsafe */ + +int main() +{ + int v = nondet() % 10; + int j; + int* i; + int a; + int* b; + int c = 0; + if(v) i = (int*)malloc(sizeof(int)); + + + for(j = 0; j < 4; j++) { + v += (nondet() % 4); + } + + for(a = 0; a <4; a++) { + c += 2; + } + if (v) { + b = (int*)malloc(sizeof(int)*c); + } + if(v) { + *i = 0; + free(i); + } + return 0; +} diff --git a/test/cex/simple/complicated_safe.c b/test/cex/simple/complicated_safe.c new file mode 100644 index 0000000..eba6917 --- /dev/null +++ b/test/cex/simple/complicated_safe.c @@ -0,0 +1,51 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: SAFE */ + + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + + +PSLL_ENTRY cons(int a, SLL_ENTRY* d) { + PSLL_ENTRY x = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + x->Data = a; + x->Flink = d; + return x; +} + +int main() +{ + int i; + int *target = NULL; + SLL_ENTRY* list = NULL; + + for(i = 0; i < 5; ++i) { + int input = nondet(); + if (input != 3) { + list = cons(input, list); + } + } + + while(list) { + SLL_ENTRY* tmp; + if(list->Data != 3) { + target = (int*)malloc(sizeof(int)); + } + + *target = 15; + + if(target) { + free(target); + target = NULL; + } + tmp = list; + list = list->Flink; + free(tmp); + } +} diff --git a/test/cex/simple/complicated_unsafe.c b/test/cex/simple/complicated_unsafe.c new file mode 100644 index 0000000..a490661 --- /dev/null +++ b/test/cex/simple/complicated_unsafe.c @@ -0,0 +1,51 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + + +PSLL_ENTRY cons(int a, SLL_ENTRY* d) { + PSLL_ENTRY x = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + x->Data = a; + x->Flink = d; + return x; +} + +int main() +{ + int i; + int *target = NULL; + SLL_ENTRY* list = NULL; + + for(i = 0; i < 5; ++i) { + int input = nondet(); + if (input != 3) { + list = cons(input, list); + } + } + + while(list) { + SLL_ENTRY* tmp; + if(list->Data != 2) { + target = (int*)malloc(sizeof(int)); + } + + *target = 15; + + if(target) { + free(target); + target = NULL; + } + tmp = list; + list = list->Flink; + free(tmp); + } +} diff --git a/test/cex/simple/maybe_malloc_then_write.c b/test/cex/simple/maybe_malloc_then_write.c new file mode 100644 index 0000000..f6ed22f --- /dev/null +++ b/test/cex/simple/maybe_malloc_then_write.c @@ -0,0 +1,23 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +/* JEK: a and b are still irrelevant, i.e. sliceable, here*/ + +void main() +{ + int* x; + int a; + + if (nondet()) { + x = malloc(sizeof(int)); + } + + while (nondet()) { + *x = a; + } + +} diff --git a/test/cex/simple/no_loops_unsafe.c b/test/cex/simple/no_loops_unsafe.c new file mode 100644 index 0000000..21df407 --- /dev/null +++ b/test/cex/simple/no_loops_unsafe.c @@ -0,0 +1,30 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +int main() +{ + int *a; + int *b; + int *c; + int *d; + + if(nondet()) { + a = (int*)malloc(sizeof(int)); + } + + if(nondet()) { + b = a; + } + + if(nondet()) { + c = b; + } + + if(nondet()) { + d = c; + } + + *d = 17; + free(b); +} diff --git a/test/cex/simple/nontrivial_list_2_unsafe.c b/test/cex/simple/nontrivial_list_2_unsafe.c new file mode 100644 index 0000000..f609c40 --- /dev/null +++ b/test/cex/simple/nontrivial_list_2_unsafe.c @@ -0,0 +1,27 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + +int main() { + int i; + int j = nondet()%3+5; + SLL_ENTRY* list = NULL; + while(nondet() || j) { + SLL_ENTRY* tmp = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = list; + list = tmp; + j--; + } + + j = nondet()%5+5; + + for(i = 0; i < j; i++) { + list = list->Flink; + } + return 0; +} diff --git a/test/cex/simple/nontrivial_list_2_unsafe_garbage.c b/test/cex/simple/nontrivial_list_2_unsafe_garbage.c new file mode 100644 index 0000000..d9a8ce8 --- /dev/null +++ b/test/cex/simple/nontrivial_list_2_unsafe_garbage.c @@ -0,0 +1,45 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* JEK: a, b and c should be irrelevant, i.e. sliceable, here + interesting: a is actually connected to j - can we still slice it? */ + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + +int main() { + int i; + int j = nondet()%3+5; + SLL_ENTRY* list = NULL; + int a; + int* b; + SLL_ENTRY* c = NULL; + while(nondet() || j) { + SLL_ENTRY* tmp = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = list; + list = tmp; + j--; + } + + for(a = 0; a < j; a++) { + SLL_ENTRY* tmp = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = c; + c = tmp; + } + + j = nondet()%5+5; + + while( c != NULL) { + SLL_ENTRY* tmp = c ; + c = c->Flink ; + free(tmp); + } + + for(i = 0; i < j; i++) { + list = list->Flink; + } + return 0; +} diff --git a/test/cex/simple/nontrivial_list_unsafe.c b/test/cex/simple/nontrivial_list_unsafe.c new file mode 100644 index 0000000..fa2fcc5 --- /dev/null +++ b/test/cex/simple/nontrivial_list_unsafe.c @@ -0,0 +1,23 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + +int main() { + int i = 0; + SLL_ENTRY* list = NULL; + for(i = 0; i < 5; i++) { + SLL_ENTRY* tmp = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = list; + list = tmp; + } + + for(i = 0; i < 7; i++) { + list = list->Flink; + } + return 0; +} diff --git a/test/cex/simple/serious_unsafe.c b/test/cex/simple/serious_unsafe.c new file mode 100644 index 0000000..a69a891 --- /dev/null +++ b/test/cex/simple/serious_unsafe.c @@ -0,0 +1,138 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/***************************************************************************** + 1394 Feature: cleanup_isochresourcedata_remove_head_list_unsafe. + Expected Result: POSSIBLY UNSAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + +#define WHILE while +#define TRUE (1==1) + +NTSTATUS t1394_SubmitIrpSynch(WDFIOTARGET IoTarget, WDFREQUEST Request, PIRB Irb) +{ + int x; + if (x) { + return STATUS_SUCCESS; + } else { + return STATUS_UNSUCCESSFUL; + } +} + +/* Source: WDK/src_5239/kmdf/1394/pnp.c, line 634. */ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( +/* IN WDFDEVICE Device */ + PDEVICE_EXTENSION deviceExtension /* added for SLAyer */ + ) +{ + PLIST_ENTRY listEntry; + + // + // Remove any isoch resource data + // + WHILE (TRUE) { + + WdfSpinLockAcquire(deviceExtension->IsochResourceSpinLock); + + if (!IsListEmpty(&deviceExtension->IsochResourceData)) { + + PISOCH_RESOURCE_DATA IsochResourceData = NULL; + +/* SLAyer: memory unsafety in original code. Reported as Windows 8 Bug #59410. Fixed by Patrick Maninger 9/Aug/2010. */ + listEntry = RemoveHeadList(&deviceExtension->CromData); + + IsochResourceData = CONTAINING_RECORD(listEntry, + ISOCH_RESOURCE_DATA, + IsochResourceList); + + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + +/* TRACE(TL_TRACE, ("Surprise Removal: IsochResourceData = 0x%x\n", */ +/* IsochResourceData)); */ + + if (IsochResourceData) { + + PIRB pIrb; + WDFREQUEST request; + NTSTATUS status; + +/* TRACE(TL_TRACE, ("Surprise Removal: Freeing hResource = 0x%x\n", */ +/* IsochResourceData->hResource)); */ + + status = WdfRequestCreate( + WDF_NO_OBJECT_ATTRIBUTES, + deviceExtension->StackIoTarget, + &request); + + if (!NT_SUCCESS(status)) { +/* TRACE(TL_ERROR, ("Failed to allocate request %x\n", status)); */ + free(IsochResourceData); /* SLAyer: added */ + } + else { + + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + + if (!pIrb) { + + WdfObjectDelete(request); + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ + free(IsochResourceData); /* SLAyer: added */ + } + else { + + RtlZeroMemory (pIrb, sizeof (IRB)); + pIrb->FunctionNumber = REQUEST_ISOCH_FREE_RESOURCES; + pIrb->Flags = 0; + pIrb->u.IsochFreeResources.hResource = IsochResourceData->hResource; + + status = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, request, pIrb); + free(IsochResourceData); /* SLAyer: added */ + + if (!NT_SUCCESS(status)) { + +/* TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", status)); */ + } + + ExFreePool(pIrb); + WdfObjectDelete(request); + } + } + } + } + else { + + + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + break; + } + } + +/* EXIT("t1394_PnpRemoveDevice", STATUS_SUCCESS); */ + +} + + +NTSTATUS +main() +{ + DEVICE_EXTENSION devExt; + unsigned int count, i; // count=* + + InitializeListHead(&(devExt.IsochResourceData)); + + for (i=0; iIsochResourceList)); + } + + // 2. Delete all Isochresourcedatas. + t1394_EvtDeviceSelfManagedIoCleanup(&devExt); + + return STATUS_SUCCESS; +} + + diff --git a/test/cex/simple/simple_list_unsafe.c b/test/cex/simple/simple_list_unsafe.c new file mode 100644 index 0000000..1682f0b --- /dev/null +++ b/test/cex/simple/simple_list_unsafe.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + +int main() +{ + int i; + SLL_ENTRY* list = NULL; + for(i = 0; i < 10; i++) { + SLL_ENTRY* tmp = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = list; + list = tmp; + } + + while(nondet()) { + list = list->Flink; + } + return 0; +} diff --git a/test/cex/simple/simple_loop_unsafe.c b/test/cex/simple/simple_loop_unsafe.c new file mode 100644 index 0000000..cbf0864 --- /dev/null +++ b/test/cex/simple/simple_loop_unsafe.c @@ -0,0 +1,21 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +int main() +{ + int *i = NULL; + int j; + + for(j = 0; j < 5; j++) { + if(nondet()) { + i = (int*)malloc(sizeof(int)); + } + } + + *i = 1; + free(i); +} diff --git a/test/cex/simple/simple_loop_unsafe_garbage.c b/test/cex/simple/simple_loop_unsafe_garbage.c new file mode 100644 index 0000000..488a968 --- /dev/null +++ b/test/cex/simple/simple_loop_unsafe_garbage.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/*JEK: a and b, nd all their commands, should be irrelevent, i.e. sliceable here */ + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +int main() +{ + int a = 7; + int *b = NULL; + int *i = NULL; + int j; + + for(j = 0; j < 5; j++) { + if(nondet()) { + i = (int*)malloc(sizeof(int)); + a ++ ; + } + } + + b = (int*)malloc(a*(sizeof(int))); + *i = 1; + free(b); + free(i); +} diff --git a/test/cex/simple/two_loops_unsafe.c b/test/cex/simple/two_loops_unsafe.c new file mode 100644 index 0000000..19247e8 --- /dev/null +++ b/test/cex/simple/two_loops_unsafe.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +int main() +{ + int *i = NULL; + int *k = NULL; + int j; + + for(j = 0; j < 45; j++) { + if(nondet()) { + i = (int*)malloc(sizeof(int)); + } + } + + for(j = 0; j < 17; j++) { + if(nondet()) { + k = i; + } + } + + *k = 1; + free(k); +} diff --git a/test/cex/simple/very_simple_unsafe.c b/test/cex/simple/very_simple_unsafe.c new file mode 100644 index 0000000..9cfecee --- /dev/null +++ b/test/cex/simple/very_simple_unsafe.c @@ -0,0 +1,14 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + + +int main() +{ + int* x; + *x = 3; + return 0; +} diff --git a/test/cex/simple/very_simple_unsafe_garbage_4.c b/test/cex/simple/very_simple_unsafe_garbage_4.c new file mode 100644 index 0000000..0dbed77 --- /dev/null +++ b/test/cex/simple/very_simple_unsafe_garbage_4.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +/* JEK: a and b are still irrelevant, i.e. sliceable, here + - easy, because *x=a; not in error-path ... */ + +int main() +{ + int* x; + int a = 2; + int* b; + b = malloc(sizeof(int)*a); + + x = malloc(sizeof(int)); + *x = a; + + free(x); + *x = 3; + return 0; +} diff --git a/test/cex/simple/very_simple_unsafe_garbage_easy.c b/test/cex/simple/very_simple_unsafe_garbage_easy.c new file mode 100644 index 0000000..2bb619d --- /dev/null +++ b/test/cex/simple/very_simple_unsafe_garbage_easy.c @@ -0,0 +1,18 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +/* JEK: a and b are irrelevant, i.e. sliceable here */ + +int main() +{ + int* x; + int a = 2; + int* b; + b = malloc(sizeof(int)*a); + *x = 3; + return 0; +} diff --git a/test/cex/simple/very_simple_unsafe_garbage_even_less_easy.c b/test/cex/simple/very_simple_unsafe_garbage_even_less_easy.c new file mode 100644 index 0000000..e019dc1 --- /dev/null +++ b/test/cex/simple/very_simple_unsafe_garbage_even_less_easy.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +/* JEK: a and b are still irrelevant, i.e. sliceable, here*/ + +int main() +{ + int* x; + int a = 2; + int* b; + b = malloc(sizeof(int)*a); + + if (nondet()) { + x = malloc(sizeof(int)); + *x = a; + } + + *x = 3; + return 0; +} diff --git a/test/cex/simple/very_simple_unsafe_garbage_less_easy.c b/test/cex/simple/very_simple_unsafe_garbage_less_easy.c new file mode 100644 index 0000000..9e04585 --- /dev/null +++ b/test/cex/simple/very_simple_unsafe_garbage_less_easy.c @@ -0,0 +1,23 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +/* Result: POSSIBLY UNSAFE *\ +\* Expected Result: UNSAFE */ + +/* JEK: a and b are still irrelevant, i.e. sliceable, here*/ + +int main() +{ + int* x; + int a = 2; + int* b; + b = malloc(sizeof(int)*a); + + if (nondet()) { + x = malloc(sizeof(int)*a); + } + + *x = 3; + return 0; +} diff --git a/test/cex/sll/append_fs_unsafe.c b/test/cex/sll/append_fs_unsafe.c new file mode 100644 index 0000000..07aa77c --- /dev/null +++ b/test/cex/sll/append_fs_unsafe.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void append(PSLL_ENTRY *a, PSLL_ENTRY y) { + PSLL_ENTRY *z = a; + + while(*z != NULL) { + z = &(*z)->Flink; + } + *z = y; +} + +void main() { + PSLL_ENTRY x, x1, x2, x3, y, y1, y2; + x3 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = NULL; + x2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x2->Flink = x3; + x1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x1->Flink = x2; + x = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x->Flink = x1; + y2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y2->Flink = NULL; + y1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y1->Flink = y2; + y = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y->Flink = y1; + append(&x, y); + free(x3->Flink); + SLL_destroy(x); +} diff --git a/test/cex/sll/append_ret_fs_unsafe.c b/test/cex/sll/append_ret_fs_unsafe.c new file mode 100644 index 0000000..402b9e6 --- /dev/null +++ b/test/cex/sll/append_ret_fs_unsafe.c @@ -0,0 +1,33 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY append(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY t, n, r; + if (x != NULL) { + t = x; + n = x->Flink; + while (n != NULL) { + n = n->Flink; + t = n; + } + t->Flink = y; + return x; + } else { + return y; + } +} + +void main() { + PSLL_ENTRY x, x1, x2, x3, y, y1, y2; + x3 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = NULL; + x2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x2->Flink = x3; + x1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x1->Flink = x2; + x = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x->Flink = x1; + free(x3->Flink); + y2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y2->Flink = NULL; + y1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y1->Flink = y2; + y = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y->Flink = y1; + x = append(x, y); + SLL_destroy(x); +} diff --git a/test/cex/sll/append_ret_unsafe.c b/test/cex/sll/append_ret_unsafe.c new file mode 100644 index 0000000..c6613ce --- /dev/null +++ b/test/cex/sll/append_ret_unsafe.c @@ -0,0 +1,27 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY append(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY t, n, r; + if (x != NULL) { + t = x; + n = x->Flink; + while (n != NULL) { + n = n->Flink; + t = n; + } + t->Flink = y; + return x; + } else { + return y; + } +} + +void main() { + PSLL_ENTRY x, y; + x = SLL_create(nondet()); + y = SLL_create(nondet()); + x = append(x, y); + SLL_destroy(x); +} diff --git a/test/cex/sll/append_unsafe.c b/test/cex/sll/append_unsafe.c new file mode 100644 index 0000000..adc7357 --- /dev/null +++ b/test/cex/sll/append_unsafe.c @@ -0,0 +1,20 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void append(PSLL_ENTRY* z, PSLL_ENTRY y) { + while(*z != NULL) { + z = &(*z)->Flink; + } + *z = y; +} + +void main() { + PSLL_ENTRY x, y, z; + x = SLL_create(nondet()); + y = SLL_create(nondet()); + z = SLL_create(nondet()); + append(&x, y); + free(&z); + SLL_destroy(x); +} diff --git a/test/cex/sll/copy_fs_unsafe.c b/test/cex/sll/copy_fs_unsafe.c new file mode 100644 index 0000000..8ab7610 --- /dev/null +++ b/test/cex/sll/copy_fs_unsafe.c @@ -0,0 +1,30 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY copy(PSLL_ENTRY a) { + PSLL_ENTRY y, x = a; + SLL_ENTRY* * z = &y; + + while(x != NULL) /* listseg(y,*z) * listseg(-,x) * list(x) */ { + x = x->Flink; + *z = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + (*z)->Data = x->Data; + z = &(*z)->Flink; + x = x->Flink; + } + *z = NULL; + return y; +} + +void main() { + PSLL_ENTRY x, x1, x2, x3, x4, y; + x4 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = NULL; + x3 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = x4; + x2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x2->Flink = x3; + x1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x1->Flink = x2; + x = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x->Flink = x1; + y = copy(x); + SLL_destroy(x); + SLL_destroy(y); +} diff --git a/test/cex/sll/copy_leak_unsafe.c b/test/cex/sll/copy_leak_unsafe.c new file mode 100644 index 0000000..086d402 --- /dev/null +++ b/test/cex/sll/copy_leak_unsafe.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY copy(PSLL_ENTRY a) { + PSLL_ENTRY y, x = a; + SLL_ENTRY* * z = &y; + + while(x != NULL) /* listseg(y,*z) * listseg(-,x) * list(x) */ { + *z = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + (*z)->Data = x->Data; + z = &(*z)->Flink; + x = x->Flink; + } + *z = NULL; + return y; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = SLL_create(nondet()); + y = copy(x); + free(&y); +/* SLL_destroy(x); */ +/* SLL_destroy(y); */ +} diff --git a/test/cex/sll/copy_unsafe.c b/test/cex/sll/copy_unsafe.c new file mode 100644 index 0000000..d82f66d --- /dev/null +++ b/test/cex/sll/copy_unsafe.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY copy(PSLL_ENTRY a) { + PSLL_ENTRY y, x = a; + SLL_ENTRY* * z = &y; + + while(x != NULL) /* listseg(y,*z) * listseg(-,x) * list(x) */ { + *z = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + (*z)->Data = x->Data; + z = &(*z)->Flink; + x = x->Flink; + } + *z = NULL; + return y; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = SLL_create(nondet()); + SLL_destroy(x); + y = copy(x); +} diff --git a/test/cex/sll/create_body_unsafe.c b/test/cex/sll/create_body_unsafe.c new file mode 100644 index 0000000..321833f --- /dev/null +++ b/test/cex/sll/create_body_unsafe.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = head->Flink; + printf_s("created link\n") ; + + return head; +} + +void main(void) { + PSLL_ENTRY x; + + x = create(1); + + free(x); +} diff --git a/test/cex/sll/create_kernel_unsafe.c b/test/cex/sll/create_kernel_unsafe.c new file mode 100644 index 0000000..b078801 --- /dev/null +++ b/test/cex/sll/create_kernel_unsafe.c @@ -0,0 +1,43 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create and then leak a doubly-linked list. + This is a kernel-style list, in which the payload is adjacent to the links. + + This is a generalization of the harness setup in + kmdf/1394/address_range_plist_entry. + + *****************************************************************************/ + +#include "slayer.h" +#include "../kmdf/harness.h" +#include "../kmdf/1394.h" + + +void main() +{ + PDEVICE_EXTENSION deviceExtension; + int* addr_range ; + ASYNC_ADDRESS_DATA *aad ; + int aad_count, i ; + + deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(DEVICE_EXTENSION)); + InitializeListHead(&(deviceExtension->AsyncAddressData)); + + for (i=0; ipMdl = (PMDL)malloc(sizeof(MDL)); + + aad->Buffer = malloc(1); + + aad->AddressRange = (PADDRESS_RANGE)malloc(sizeof(ADDRESS_RANGE)); + + InsertHeadList(&(deviceExtension->AsyncAddressData), &(aad->AsyncAddressList)); + } + + assert(aad=NULL); + return ; + +} diff --git a/test/cex/sll/create_via_tmps_unsafe.c b/test/cex/sll/create_via_tmps_unsafe.c new file mode 100644 index 0000000..61e416b --- /dev/null +++ b/test/cex/sll/create_via_tmps_unsafe.c @@ -0,0 +1,19 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + + +void main(void) { + PSLL_ENTRY x= NULL; + int i, len; + for (i=0; iData == i) { + t = *z; + free(t); + *z = t->Flink; + } else { + z = &(*z)->Flink; + } +} + +void main() { + PSLL_ENTRY x, x1, x2, x3, x4, x5; + x5 = cons(1, NULL); + x4 = cons(4, x5); + x3 = cons(1, x4); + x2 = cons(3, x3); + x1 = cons(2, x2); + x = cons(1, x1); + print_list(x); printf_s("\n"); + filter(&x, 1); + print_list(x); + SLL_destroy(x); +} diff --git a/test/cex/sll/filter_ret_unsafe.c b/test/cex/sll/filter_ret_unsafe.c new file mode 100644 index 0000000..eb3b4a2 --- /dev/null +++ b/test/cex/sll/filter_ret_unsafe.c @@ -0,0 +1,47 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + version of filter that does not use sub-object pointers, and hence must + special-case removing the first link and return the filtered list +*/ + +#include "sll.h" + +/* remove all links with Data a from x */ +PSLL_ENTRY filter(PSLL_ENTRY x, int a) { + PSLL_ENTRY y, z; + + y = x; + z = NULL; + while(y != NULL) { + if(y->Data == a) { /* need to remove y */ + if(y == x) { /* first link */ + free(y); + x = y->Flink; + y = x; + } else { /* not first link */ + z->Flink = y->Flink; + free(y); + y = z->Flink; + } + } else { /* don't need to remove y */ + z = y; + y = y->Flink; + } + } + return x; +} + +void main() { + PSLL_ENTRY x = NULL; + x = cons(1, x); + x = cons(4, x); + x = cons(1, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + x = filter(x, 1); + print_list(x); + SLL_destroy(x); +} diff --git a/test/cex/sll/filter_unsafe.c b/test/cex/sll/filter_unsafe.c new file mode 100644 index 0000000..37a0ed9 --- /dev/null +++ b/test/cex/sll/filter_unsafe.c @@ -0,0 +1,30 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void filter(PSLL_ENTRY *a, int i) { + PSLL_ENTRY t, *z = a; + + while(*z != NULL) + if((*z)->Data == i) { + t = *z; + *z = t->Flink; + free(t); + } else { + z = &(*z)->Flink; + } + + free(t); +} + +void main() { + PSLL_ENTRY x = SLL_create(nondet()); + + print_list(x); printf_s("\n"); + + filter(&x, 1); + + print_list(x); + + SLL_destroy(x); +} diff --git a/test/cex/sll/insertion_sort_inlined_lead_unsafe.c b/test/cex/sll/insertion_sort_inlined_lead_unsafe.c new file mode 100644 index 0000000..423ce18 --- /dev/null +++ b/test/cex/sll/insertion_sort_inlined_lead_unsafe.c @@ -0,0 +1,32 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void main() { + PSLL_ENTRY x = NULL, y, c, h, elem, prev; + x = SLL_create(17); + + c = x; + x = NULL; + while (c != NULL) { + c = c->Flink; + y = c; + y->Flink = NULL; + elem = x; + prev = NULL; + while (elem != NULL) { + if (elem->Data >= y->Data) { + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + goto retn; + } + prev = elem; + elem = elem->Flink; + } + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + retn: ; + } +} diff --git a/test/cex/sll/insertion_sort_inlined_unsafe.c b/test/cex/sll/insertion_sort_inlined_unsafe.c new file mode 100644 index 0000000..62a0071 --- /dev/null +++ b/test/cex/sll/insertion_sort_inlined_unsafe.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void main() { + PSLL_ENTRY x = NULL, y, c, h, elem, prev; + x = SLL_create(17); + + c = x; + x = NULL; + while (c != NULL) { + y = c; + c = c->Flink; + y->Flink = NULL; + elem = x; + prev = NULL; + while (elem != NULL) { + if (elem->Data >= y->Data) { + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + goto retn; + } + elem = elem->Flink; + prev = elem; + } + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + retn: ; + } + + SLL_destroy(c); + SLL_destroy(x); +} diff --git a/test/cex/sll/insertion_sort_unsafe.c b/test/cex/sll/insertion_sort_unsafe.c new file mode 100644 index 0000000..2678bde --- /dev/null +++ b/test/cex/sll/insertion_sort_unsafe.c @@ -0,0 +1,43 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY insert(PSLL_ENTRY l, PSLL_ENTRY x) { + PSLL_ENTRY elem, prev; + elem = l; + prev = NULL; + while (elem != NULL) { + if (elem->Data >= x->Data) { + x->Flink = elem; + if (prev == NULL) return x; + prev->Flink = x; + return l; + } + prev = elem; + elem = elem->Flink; + } + x->Flink = elem; + if (prev == NULL) return x; + prev->Flink = x; + return l; +} + +PSLL_ENTRY insertion_sort(PSLL_ENTRY x) { + PSLL_ENTRY h, ret, cand; + h = x; + ret = NULL; + while (h != NULL) { + h = h->Flink; + cand = h; + cand->Flink = NULL; + ret = insert(ret, cand); + } + return ret; +} + +void main() { + PSLL_ENTRY x; + x = SLL_create(17); + x = insertion_sort(x); + SLL_destroy(x); +} diff --git a/test/cex/sll/list_of_objects.c b/test/cex/sll/list_of_objects.c new file mode 100644 index 0000000..34e30c2 --- /dev/null +++ b/test/cex/sll/list_of_objects.c @@ -0,0 +1,33 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create and destroy a singly-linked list of pointers to heap objects. +**/ + +#include "slayer.h" + + +typedef struct _SLL_ENTRY { + void* Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + + +void main(void) { + PSLL_ENTRY head, item; + + head = NULL; + while (nondet()) { + item = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + item->Data = (int*)malloc(sizeof(int)); + item->Flink = head; + head = item; + } + + while (head) { + item = head; + head = item->Flink; + free(item->Data); + free(item); + } +} diff --git a/test/cex/sll/list_of_objects_unsafe.c b/test/cex/sll/list_of_objects_unsafe.c new file mode 100644 index 0000000..9334fc0 --- /dev/null +++ b/test/cex/sll/list_of_objects_unsafe.c @@ -0,0 +1,33 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create and destroy a singly-linked list of pointers to heap objects. +**/ + +#include "slayer.h" + + +typedef struct _SLL_ENTRY { + void* Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + + +void main(void) { + PSLL_ENTRY head, item; + + head = NULL; + while (nondet()) { + item = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + item->Data = (int*)malloc(sizeof(int)); + head = item; + item->Flink = head; + } + + while (head) { + item = head; + head = item->Flink; + free(item->Data); + free(item); + } +} diff --git a/test/cex/sll/remove_ret_unsafe.c b/test/cex/sll/remove_ret_unsafe.c new file mode 100644 index 0000000..f87a18c --- /dev/null +++ b/test/cex/sll/remove_ret_unsafe.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY sll_remove(PSLL_ENTRY l, PSLL_ENTRY x) { + PSLL_ENTRY elem, prev, t; + elem = l; + prev = NULL; + while (elem != NULL) { + if (elem == x) { + if (prev == NULL) { + t = elem->Flink; + free(elem); + return t; + } else { + free(elem); + t = elem->Flink; + prev->Flink = t; + } + return l; + } + prev = elem; + elem = elem->Flink; + } + return l; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + y = cons(3, y); + y = cons(2, y); + x = cons(1, y); + x = sll_remove(x, y); + SLL_destroy(x); +} diff --git a/test/cex/sll/reverse_div2_unsafe.c b/test/cex/sll/reverse_div2_unsafe.c new file mode 100644 index 0000000..6675512 --- /dev/null +++ b/test/cex/sll/reverse_div2_unsafe.c @@ -0,0 +1,39 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse_div2.c but is also unsafe due to an omitted NULL test. +**/ + +#include "sll.h" + + +void reverse_div(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + c = c->Flink; + t->Flink = r; + r = t; + if (nondet() /* && z!=NULL */) { + t = c; + c = c->Flink; + t->Flink = r; + r = t; + } + } + *l = r; +} + + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse_div(&head); + + SLL_destroy(head); +} diff --git a/test/cex/sll/reverse_div3_unsafe.c b/test/cex/sll/reverse_div3_unsafe.c new file mode 100644 index 0000000..14742db --- /dev/null +++ b/test/cex/sll/reverse_div3_unsafe.c @@ -0,0 +1,35 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, attempt to reverse, and then destroy a singly-linked list. + + Similar to reverse.c but sometimes breaks the list, gets lost, and + diverges. May also crash when destroying a cyclic list created by + the broken reversal. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + if (c->Data != 5) + c = c->Flink; + r = t; + t->Flink = r; + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/cex/sll/reverse_div4_unsafe.c b/test/cex/sll/reverse_div4_unsafe.c new file mode 100644 index 0000000..1ed799f --- /dev/null +++ b/test/cex/sll/reverse_div4_unsafe.c @@ -0,0 +1,31 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/** + Create, attempt to reverse, and then leak a singly-linked list. + + Similar to reverse_div3.c but never advances the cursor pointer. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + r = t; + t->Flink = r; + t = c; + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/cex/sll/reverse_div_unsafe.c b/test/cex/sll/reverse_div_unsafe.c new file mode 100644 index 0000000..1983811 --- /dev/null +++ b/test/cex/sll/reverse_div_unsafe.c @@ -0,0 +1,35 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse.c but may nondeterministically do nothing during + reversal, thereby causing divergence. +**/ + +#include "sll.h" + + +void reverse_div(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + if (nondet()) { /* nondeterministically do nothing */ + PSLL_ENTRY t; + c = c->Flink; + t = c; + t->Flink = r; + r = t; + } + } + *l = r; +} + + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse_div(&head); + + SLL_destroy(head); +} diff --git a/test/cex/sll/reverse_leak2_unsafe.c b/test/cex/sll/reverse_leak2_unsafe.c new file mode 100644 index 0000000..ef9b82d --- /dev/null +++ b/test/cex/sll/reverse_leak2_unsafe.c @@ -0,0 +1,34 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse_leak.c but chooses leaked item nondeterministically. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + c = c->Flink; + t = c; + if (nondet()) { /* leak t */ + t->Flink = r; + r = t; + } + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/cex/sll/reverse_leak_unsafe.c b/test/cex/sll/reverse_leak_unsafe.c new file mode 100644 index 0000000..a4ae6af --- /dev/null +++ b/test/cex/sll/reverse_leak_unsafe.c @@ -0,0 +1,34 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse.c but may leak an item. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + c = c->Flink; + t = c; + if (t->Data != 1) { /* leak t */ + t->Flink = r; + r = t; + } + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/cex/sll/reverse_negative_sublists_unsafe.c b/test/cex/sll/reverse_negative_sublists_unsafe.c new file mode 100644 index 0000000..9410277 --- /dev/null +++ b/test/cex/sll/reverse_negative_sublists_unsafe.c @@ -0,0 +1,85 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void reverse_negative_sublists(PSLL_ENTRY *a) /* o==z | list(*z) */ { + PSLL_ENTRY *z = a; + + PSLL_ENTRY t, x = *z, y, *w; + while(x != NULL) /* *z==x | listseg(*o,*z) * list(x) */ { + while(x != NULL && x->Data >= 0) /* listseg(*o,*z) * list(x) */ { + z = &(x->Flink); + x = *z; + } + if(x != NULL) { + /* listseg(*o,*z) * x|->x' * list(x') */ + y = x; + w = &(x->Flink); + /* y==x /| *w==x' | listseg(*o,*z) * x|->-,x' * list(x') */ + while(x != NULL && x->Data < 0) /* listseg(y,*w) * list(x) */ { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + /* listseg(*o,*z) * listseg(y,*w) * list(x) */ + *w = x; + /* listseg(*o,*z) * listseg(y,x) * list(x) */ + *z = y; + /* listseg(*o,x) * list(x) */ + } else { + *z = NULL; + } + } +} /* list(*o) */ + +/* a version that doesn't use pointers into records, call-by-reference, or + conditional assertions */ +PSLL_ENTRY reverse_negative_sublists2(PSLL_ENTRY a) /* o==x | list(x) */ { + PSLL_ENTRY x = a; + + PSLL_ENTRY t, y, w, v=cons(0,x), z=v; + while(x != NULL) /* listseg(o,z) * z|->-,x * list(x) */ { + while(x != NULL && x->Data >= 0) /* listseg(o,z) * z|->-,x * list(x) */ { + z = x; + x = x->Flink; + } + if(x != NULL) { + /* listseg(o,z) * z|->-,x * x|->x' * list(x') */ + y = w = x; + /* y==w==x | listseg(o,z) * z|->-,w * w|->-,x' * list(x') */ + do { + x = x->Flink; + t = x; + t->Flink = y; + y = t; + } while(x != NULL && x->Data < 0); /* listseg(y,w) * w|->- * list(x) */ + /* listseg(o,z) * z|->-,w * listseg(y,w) * w|->- * list(x) */ + w->Flink = x; + /* listseg(o,z) * z|->-,w * listseg(y,w) * w|->-,x * list(x) */ + z->Flink = y; + /* listseg(o,z) * z|->-,y * listseg(y,w) * w|->-,x * list(x) */ + /* listseg(o,w) * w|->-,x * list(x) */ + /* the following assignment is operationally irrelevant, but we can't + express the following stronger invariant for the outer loop: + (x != NULL && x->Data >= 0 ? listseg(o,x) : listseg(o,z) * z|->-,x) + * list(x) */ + z = w; + /* listseg(o,z) * z|->-,x * list(x) */ + /* listseg(o,x) * list(x) */ + } else { + z->Flink = NULL; + } + } + t = v->Flink; + free(v); + return t; +} /* list(o) */ + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + x = reverse_negative_sublists2(x); + reverse_negative_sublists(&x); + SLL_destroy(x); +} diff --git a/test/cex/sll/reverse_ret_unsafe.c b/test/cex/sll/reverse_ret_unsafe.c new file mode 100644 index 0000000..27f6185 --- /dev/null +++ b/test/cex/sll/reverse_ret_unsafe.c @@ -0,0 +1,27 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY reverse(PSLL_ENTRY a) { + PSLL_ENTRY x = a; + PSLL_ENTRY o, t; + o = NULL; + while (x != NULL) { + t = x->Flink; + x->Flink = o; + o = x; + x = t; + } + return o; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + x = reverse(x); + assert(x==NULL); + SLL_destroy(x); +} diff --git a/test/cex/sll/reverse_seg_cyclic_unsafe.c b/test/cex/sll/reverse_seg_cyclic_unsafe.c new file mode 100644 index 0000000..92cf9c5 --- /dev/null +++ b/test/cex/sll/reverse_seg_cyclic_unsafe.c @@ -0,0 +1,30 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then leak a singly-linked list segment. + + Similar to reverse_seg.c but the segment might be cyclic or a lasso. +**/ + +#include "sll.h" + + +void reverse_seg(PSLL_ENTRY *z, SLL_ENTRY *w) { + PSLL_ENTRY t, x = *z, y = w; + while(x != w) { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + *z = y; +} + +void main() { + int length; + PSLL_ENTRY head, tail; + + head = SLL_create_seg(length, tail); + head = NULL; + reverse_seg(&head, tail); +} diff --git a/test/cex/sll/reverse_seg_unsafe.c b/test/cex/sll/reverse_seg_unsafe.c new file mode 100644 index 0000000..3d430e5 --- /dev/null +++ b/test/cex/sll/reverse_seg_unsafe.c @@ -0,0 +1,34 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list segment. +**/ + +#include "sll.h" + + +void reverse_seg(PSLL_ENTRY *z, SLL_ENTRY *w) { + PSLL_ENTRY t, x = *z, y = w; + while(x != w) { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + *z = y; +} + +void main() { + int length; + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + + head = SLL_create_seg(length, tail); + + reverse_seg(&head, tail); + + SLL_destroy_seg(head, tail); + free(tail); + free(head); +} diff --git a/test/cex/sll/reverse_unsafe.c b/test/cex/sll/reverse_unsafe.c new file mode 100644 index 0000000..2932b5a --- /dev/null +++ b/test/cex/sll/reverse_unsafe.c @@ -0,0 +1,34 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +/* + Reverse the list pointed to by l. + Implemented by poping off each item of *l into r. +*/ +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + c = c->Flink; + t = c; + t->Flink = r; + r = t; + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/cex/sll/splice_unsafe.c b/test/cex/sll/splice_unsafe.c new file mode 100644 index 0000000..58def92 --- /dev/null +++ b/test/cex/sll/splice_unsafe.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY splice(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY p, q, t; + p = x; + q = y; + if (p == NULL) return q; + if (q == NULL) return p; + while (1) { + q = t->Flink; + t = q; + t->Flink = p->Flink; + p->Flink = t; + if (p == NULL) return x; + p = t->Flink; + if (q == NULL) return x; + if (p == NULL) { + t->Flink = q; + return x; + } + } + if (p == NULL) + t->Flink = q; + return x; +} + +void main() { + PSLL_ENTRY x, y, z; + x = SLL_create(nondet()); + y = SLL_create(nondet()); + z = splice(x, y); + SLL_destroy(z); +} diff --git a/test/cex/sll/traverse3_unsafe.c b/test/cex/sll/traverse3_unsafe.c new file mode 100644 index 0000000..b7e3308 --- /dev/null +++ b/test/cex/sll/traverse3_unsafe.c @@ -0,0 +1,28 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. + + Similar to traverse.c but only conditionally performs the creation and + traversal. +**/ + +#include "sll.h" + +void traverse(PSLL_ENTRY head) { + PSLL_ENTRY tmp = head->Flink; + + while(tmp != NULL) { + tmp = tmp->Flink ; + } +} + + +void main(void) { + PSLL_ENTRY head; + int length; + + head = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); +} diff --git a/test/cex/sll/traverse_1lists_unsafe.c b/test/cex/sll/traverse_1lists_unsafe.c new file mode 100644 index 0000000..1851bdf --- /dev/null +++ b/test/cex/sll/traverse_1lists_unsafe.c @@ -0,0 +1,24 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + traverse(head); + free(head1); + SLL_destroy(head); +} diff --git a/test/cex/sll/traverse_2lists_unsafe.c b/test/cex/sll/traverse_2lists_unsafe.c new file mode 100644 index 0000000..404e542 --- /dev/null +++ b/test/cex/sll/traverse_2lists_unsafe.c @@ -0,0 +1,25 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1,head2; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + head2 = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); + free(head2); +} diff --git a/test/cex/sll/traverse_5lists_unsafe.c b/test/cex/sll/traverse_5lists_unsafe.c new file mode 100644 index 0000000..eaab4f1 --- /dev/null +++ b/test/cex/sll/traverse_5lists_unsafe.c @@ -0,0 +1,28 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1,head2,head3,head4,head5; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + head2 = SLL_create(nondet()); + head3 = SLL_create(nondet()); + head4 = SLL_create(nondet()); + head5 = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); + free(head5); +} diff --git a/test/cex/sll/traverse_seg_unsafe.c b/test/cex/sll/traverse_seg_unsafe.c new file mode 100644 index 0000000..717f1b9 --- /dev/null +++ b/test/cex/sll/traverse_seg_unsafe.c @@ -0,0 +1,28 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list segment. +**/ + +#include "sll.h" + + +void traverse_seg(PSLL_ENTRY x, PSLL_ENTRY y) { + while(x != y) { + x = x->Flink; + } +} + +void main(void) { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + + head = SLL_create_seg(nondet(), tail); + + traverse_seg(head, tail); + + SLL_destroy_seg(head, tail); + free(tail); + free(head); +} diff --git a/test/cex/sll/traverse_twice_unsafe.c b/test/cex/sll/traverse_twice_unsafe.c new file mode 100644 index 0000000..a48bd92 --- /dev/null +++ b/test/cex/sll/traverse_twice_unsafe.c @@ -0,0 +1,22 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, re-traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + +void traverse(PSLL_ENTRY head) { + while(head->Flink != NULL) { + head = head->Flink; + } +} + +void main(void) { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + traverse(head); + traverse(head); + SLL_destroy(head); +} diff --git a/test/cex/sll/traverse_unsafe.c b/test/cex/sll/traverse_unsafe.c new file mode 100644 index 0000000..ee1de01 --- /dev/null +++ b/test/cex/sll/traverse_unsafe.c @@ -0,0 +1,23 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + free(head); + } +} + +void main(void) { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); +} diff --git a/test/cex/sll_rec/create_rec2_unsafe.c b/test/cex/sll_rec/create_rec2_unsafe.c new file mode 100644 index 0000000..86eef63 --- /dev/null +++ b/test/cex/sll_rec/create_rec2_unsafe.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* like create_rec.c but using length <= 0 instead of 0 <= length */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + PSLL_ENTRY head, tmp; + + if (length <= 0) { + head = NULL; + } else { + tmp = create(length - 1); + head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink = tmp->Flink; + } + return head; +} + +void main(void) { + int length; + PSLL_ENTRY head, tmp; + + length = length % 100; + tmp = head = create(length); + + print_list(head); +} diff --git a/test/cex/sll_rec/create_rec3_unsafe.c b/test/cex/sll_rec/create_rec3_unsafe.c new file mode 100644 index 0000000..61e62da --- /dev/null +++ b/test/cex/sll_rec/create_rec3_unsafe.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* like create_rec.c but allocate the new link before making the recursive + call, so that the frame is unbounded */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + PSLL_ENTRY head; + + if (0 <= length) { + head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink->Flink = create(length - 1); + } else { + head = NULL; + } + return head; +} + +void main(void) { + int length; + PSLL_ENTRY head, tmp; + + length = length % 100; + tmp = head = create(length); + + print_list(head); +} diff --git a/test/cex/sll_rec/create_rec_unsafe.c b/test/cex/sll_rec/create_rec_unsafe.c new file mode 100644 index 0000000..1646d15 --- /dev/null +++ b/test/cex/sll_rec/create_rec_unsafe.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + PSLL_ENTRY head, tmp; + + if (0 <= length) { + tmp = create(length - 1); + // head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink = tmp; + } else { + head = NULL; + } + return head; +} + +void main(void) { + int length; + PSLL_ENTRY head, tmp; + + length = length % 100; + tmp = head = create(length); + + print_list(head); +} diff --git a/test/cex/sll_rec/find_rec_unsafe.c b/test/cex/sll_rec/find_rec_unsafe.c new file mode 100644 index 0000000..65e2f67 --- /dev/null +++ b/test/cex/sll_rec/find_rec_unsafe.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +// return first link of x greater than n +PSLL_ENTRY find(PSLL_ENTRY x, int n) { + PSLL_ENTRY r; + + if (x == NULL) return NULL; + if (x->Data > n) return x; + r = find(x->Flink, n); + return r; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + assert( x==NULL); + x = cons(1, x); + y = find(x, 2); + print_list(y); +} diff --git a/test/cex/sll_rec/insertion_sort_rec_unsafe.c b/test/cex/sll_rec/insertion_sort_rec_unsafe.c new file mode 100644 index 0000000..fc9ee07 --- /dev/null +++ b/test/cex/sll_rec/insertion_sort_rec_unsafe.c @@ -0,0 +1,47 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY insert(PSLL_ENTRY a, PSLL_ENTRY x) { + PSLL_ENTRY l = a; + + if (l == NULL) { + x->Flink = NULL; + return x; + } else { + if (x->Data > l->Data) { + l->Flink = insert(l->Flink, x); + return l; + } else { + x->Flink = l; + return x; + } + } + return l; +} + +PSLL_ENTRY insertion_sort(PSLL_ENTRY x) { + PSLL_ENTRY h, ret, cand; + h = x; + ret = NULL; + while (h != NULL) { + cand = h; + h = h->Flink; + cand->Flink = NULL; + ret->Flink = insert(ret, cand); + } + return ret; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(1, x); + x = cons(9, x); + x = cons(5, x); + x = cons(7, x); + x = cons(3, x); + print_list(x); printf_s("\n"); + x = insertion_sort(x); + print_list(x); +} diff --git a/test/cex/sll_rec/merge_rec_unsafe.c b/test/cex/sll_rec/merge_rec_unsafe.c new file mode 100644 index 0000000..6d358c2 --- /dev/null +++ b/test/cex/sll_rec/merge_rec_unsafe.c @@ -0,0 +1,37 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY merge(PSLL_ENTRY p, PSLL_ENTRY q) { + PSLL_ENTRY r, t; + + if (p == NULL) return q; + if (q == NULL) return p; + if (p->Data <= q->Data) { + r = p->Flink; + t = merge(r, q); + p->Flink = t; + return p; + } else { + r = q->Flink; + t = merge(p, r); + q->Flink = t; + return q; + } + return r; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL, z; + x = cons(5, x); + x = cons(3, x); + x = cons(1, x); + assert(x==NULL); + y = cons(6, y); + y = cons(4, y); + y = cons(2, y); + print_list(x); printf_s("\n"); + print_list(y); printf_s("\n"); + z = merge(x, y); + print_list(z); +} diff --git a/test/cex/sll_rec/reverse_app_ret_rec_unsafe.c b/test/cex/sll_rec/reverse_app_ret_rec_unsafe.c new file mode 100644 index 0000000..4542f95 --- /dev/null +++ b/test/cex/sll_rec/reverse_app_ret_rec_unsafe.c @@ -0,0 +1,36 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY append(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY r; + + if (x != NULL) { + x->Flink = append(x->Flink, y); + return x; + } else { + return y; + } + return r; +} + +/* reverse recursively using append */ +PSLL_ENTRY reverse(PSLL_ENTRY x) { + PSLL_ENTRY xf, t = NULL, u; + + if (x == NULL) return t; + xf = x->Flink; + x->Flink = NULL; + t->Flink = append(reverse(xf), x); +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + x = reverse(x); + print_list(x); +} diff --git a/test/cex/sll_rec/reverse_rec_unsafe.c b/test/cex/sll_rec/reverse_rec_unsafe.c new file mode 100644 index 0000000..a0b8531 --- /dev/null +++ b/test/cex/sll_rec/reverse_rec_unsafe.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +typedef struct _SLL_ENTRY cell, *list, *listseg; + +list list_reverse_rec_aux(list x, list y) { + if(y == NULL) { + return x; + } else { + list tmp = y->Data; + y->Flink = x; + return list_reverse_rec_aux(y, tmp); + } +} + +void list_reverse(list *z) { + *z = list_reverse_rec_aux(NULL, *z); +} + +int main() { + list x; + x = cons(1, cons(2, cons(3, NULL))); + list_reverse(&x); + print_list(x); printf_s("\n"); +} diff --git a/test/cex/sll_rec/traverse_rec_nondet_unsafe.c b/test/cex/sll_rec/traverse_rec_nondet_unsafe.c new file mode 100644 index 0000000..fae5e2c --- /dev/null +++ b/test/cex/sll_rec/traverse_rec_nondet_unsafe.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; nondet(); i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY x) { + if(x->Flink != NULL) { + traverse(x->Flink); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head); + + return; +} diff --git a/test/cex/sll_rec/traverse_rec_unsafe.c b/test/cex/sll_rec/traverse_rec_unsafe.c new file mode 100644 index 0000000..17596d8 --- /dev/null +++ b/test/cex/sll_rec/traverse_rec_unsafe.c @@ -0,0 +1,36 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; i < length; i++) { + // tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY x) { + if(x != NULL) { + traverse(x->Flink); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head); +/* traverse(head); */ + + return; +} diff --git a/test/cex/sll_rec/traverse_seg_rec_nondet_unsafe.c b/test/cex/sll_rec/traverse_seg_rec_nondet_unsafe.c new file mode 100644 index 0000000..57d559e --- /dev/null +++ b/test/cex/sll_rec/traverse_seg_rec_nondet_unsafe.c @@ -0,0 +1,39 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; nondet(); i++) { + // tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY a, PSLL_ENTRY y) { + PSLL_ENTRY x = a; + + if(x != y) { + x = x->Flink; + traverse(x, y); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head, NULL); +/* traverse(head); */ + + return; +} diff --git a/test/cex/sll_rec/traverse_seg_rec_unsafe.c b/test/cex/sll_rec/traverse_seg_rec_unsafe.c new file mode 100644 index 0000000..a553ab6 --- /dev/null +++ b/test/cex/sll_rec/traverse_seg_rec_unsafe.c @@ -0,0 +1,39 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; i < length; i++) { + // tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY a, PSLL_ENTRY y) { + PSLL_ENTRY x = a; + + if(x != y) { + x = x->Flink; + traverse(x, y); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head, NULL); +/* traverse(head); */ + + return; +} diff --git a/test/config.cmd b/test/config.cmd new file mode 100644 index 0000000..aac6392 --- /dev/null +++ b/test/config.cmd @@ -0,0 +1,18 @@ +@echo off + +REM setup file for running SLAyer tests, source after SLAyer/config.cmd + +REM The slam frontend uses the SDV cl.exe. +set PATH=%SLWIN%\SLAyer\tools\sdv\product\bin;%PATH% +set PATH=%SLWIN%\SLAyer\tools\sdv\product\bin\engine;%PATH% +set PATH=%SLWIN%\SLAyer\tools\sdv\product\bin\engine\slayer;%PATH% +set PATH=%SLWIN%\SLAyer\tools\sdv\product\bin\parser\x86_esp;%PATH% +set PATH=%SLWIN%\SLAyer\tools\sdv\dev\bin;%PATH% + +REM For cl.exe to pick up slayer.h, etc. +set INCLUDE=%SLWIN%\SLAyer\include;%INCLUDE% +set INCLUDE=%SLWIN%\SLAyer\test\sll;%INCLUDE% +set INCLUDE=%SLWIN%\SLAyer\test\csll;%INCLUDE% +set INCLUDE=%SLWIN%\SLAyer\test\kmdf;%INCLUDE% +set INCLUDE=%SLWIN%\SLAyer\test\kmdf\toaster\inc;%INCLUDE% +set INCLUDE=%SLWIN%\SLAyer\test\kmdf\toaster\func\shared;%INCLUDE% diff --git a/test/config.sh b/test/config.sh new file mode 100644 index 0000000..b4c3e4b --- /dev/null +++ b/test/config.sh @@ -0,0 +1,23 @@ +#!/bin/sh + +# echo "Setting environment for running SLAyer tests" + +# setup file for running SLAyer tests, source after SLAyer/config.sh + +# The slam frontend uses the SDV cl.exe. +# (SI: even when not using sdv, we still need sdv/product/bin/parser/ARCH/EspPersist.dll.) +export PATH="$SL_UNIX/SLAyer/tools/sdv/product/bin:$PATH" +export PATH="$SL_UNIX/SLAyer/tools/sdv/product/bin/engine:$PATH" +export PATH="$SL_UNIX/SLAyer/tools/sdv/product/bin/engine/slayer:$PATH" +export PATH="$SL_UNIX/SLAyer/tools/sdv/product/bin/parser/x86_esp:$PATH" +export PATH="$SL_UNIX/SLAyer/tools/sdv/dev/bin:$PATH" + +# For cl.exe to pick up slayer.h, etc. +export INCLUDE="$SL_WIN\SLAyer\include;$INCLUDE" +export INCLUDE="$SL_WIN\SLAyer\test\sll;$INCLUDE" +export INCLUDE="$SL_WIN\SLAyer\test\csll;$INCLUDE" +export INCLUDE="$SL_WIN\SLAyer\test\kmdf;$INCLUDE" + +# Add these to your path (test/Makefile does) to compile drivers +export SL_INCLUDE_TOASTER="${SL_WIN}SLAyer\test\kmdf;${SL_WIN}SLAyer\test\kmdf\toaster\inc;${SL_WIN}SLAyer\test\kmdf\toaster\func\shared" +export SL_INCLUDE_PCIDRV="${SL_WIN}SLAyer\test\kmdf;${SL_WIN}SLAyer\test\kmdf\pci_drv;${SL_WIN}SLAyer\test\kmdf\pci_drv\HW" diff --git a/test/csll/csll.h b/test/csll/csll.h new file mode 100644 index 0000000..939afdd --- /dev/null +++ b/test/csll/csll.h @@ -0,0 +1,32 @@ +// common definitions for cyclic singly-linked lists + +#include "../sll/sll.h" + + +/* assumes cyclic list is non-empty */ +void CSLL_destroy(PSLL_ENTRY head) { + PSLL_ENTRY curr, next; + curr = head->Flink; + while( curr != head ) { + next = curr->Flink; + free(curr); + curr = next; + } + free(head); +} + + +/* assumes cyclic list is non-empty */ +void CSLL_print(PSLL_ENTRY head) { + PSLL_ENTRY curr; + + printf("("); + print_link(head); + curr = head->Flink; + do { + printf(",\n "); + print_link(curr); + curr = curr->Flink; + } while (curr != head); + printf(")\n"); +} diff --git a/test/csll/cyclic_list.c b/test/csll/cyclic_list.c new file mode 100644 index 0000000..b56e2ef --- /dev/null +++ b/test/csll/cyclic_list.c @@ -0,0 +1,78 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +// non-empty circular lists + +/* implements a stack and a queue simultaneously using a circular list: + * + * rear |-> top_front * lseg(top_front, rear) + * + * - the rear of the queue is the node pointed to by rear + * - the top of the stack and the front of the queue + * are both the node pointed to by the tl of x + * - we keep a pointer r to the rear, and existentially quantify top_front + */ +#include "slayer.h" +#include "heap.h" + +// utility functions /////////////////////////////////////////////////////////// + +void print_clist(cell* x) /* x|->-,y * ls(y,x) */ { + cell* z = x; + printf_s("("); + do { + print_cell(z); + z = z->cdr; + } while(z != x ? printf_s(", "),1 : 0); + printf_s(",...)"); +} /* x|->-,y * ls(y,x) */ + + +// operations ////////////////////////////////////////////////////////////////// + +/* push */ +void insert_after(cell* x, int n) /* x|->-,y * ls(y,x) */ { + cell* t = new(); /* x|->-,y * t|->-,- * ls(y,x) */ + t->car = n; + t->cdr = x->cdr; /* x|->-,y * t|->n,y * ls(y,x) */ + x->cdr = t; +} /* x|->-,t * t|->n,y * ls(y,x) */ + +void rotate(cell* *x) /* x|->-,y * ls(y,x) */ { + *x = (*x)->cdr; /* ls(x,x') * x'|->-,x */ +} /* x|->-,z * ls(z,x) */ + +/* enqueue */ +void insert_before(cell* *x, int n) /* x|->-,y * ls(y,x) */ { + insert_after(*x, n); /* x|->-,t * t|->n,y * ls(y,x) */ + *x = (*x)->cdr; /* spec of rotate(x); too weak to use here */ +} /* x|->n,y * ls(y,x) */ + +/* pop / dequeue */ +/* this is the spec & proof for the possibly-empty list version */ +void delete_next(cell* x) /* x|->y * ls(y,x) */ { + cell* t = x->cdr; /* t=y | x=y ? x|->y : x|->y * y|->z * ls(z,x) */ + cell* u = t->cdr; /* t=y | x=y ? x|->y : u=z | x|->y * y|->z * ls(z,x) */ + x->cdr = u; /* x=y ? t|->u : x|->z * t|->z * ls(z,x)) */ + free(t); +} /* x=y ? emp : x|->z * ls(z,x) */ + + +// test harness //////////////////////////////////////////////////////////////// + +int main() { + cell* x; + x = new(); + x->car = 0; + x->cdr = x; + printf_s("clist:\t\t"); print_clist(x); printf_s("\n"); + insert_after(x, 1); + insert_after(x, 2); + printf_s("push 1, 2:\t"); print_clist(x); printf_s("\n"); + insert_before(&x, 3); + insert_before(&x, 4); + printf_s("enqueue 3, 4:\t"); print_clist(x); printf_s("\n"); + delete_next(x); + printf_s("pop / dequeue:\t"); print_clist(x); printf_s("\n"); + rotate(&x); + printf_s("rotate:\t\t"); print_clist(x); printf_s("\n"); +} diff --git a/test/csll/destroy.c b/test/csll/destroy.c new file mode 100644 index 0000000..c167180 --- /dev/null +++ b/test/csll/destroy.c @@ -0,0 +1,19 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/** + Create and destroy a cyclic singly-linked list. + + Works by remembering the first node in the list, freeing all others, then + freeing the first one. +**/ + +#include "csll.h" + + +void main() { + PSLL_ENTRY head, tail; + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + CSLL_destroy(head); +} diff --git a/test/csll/destroy_iter_rem.c b/test/csll/destroy_iter_rem.c new file mode 100644 index 0000000..d96d1c4 --- /dev/null +++ b/test/csll/destroy_iter_rem.c @@ -0,0 +1,32 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/** + Create and destroy a cyclic singly-linked list. + + Works by iteratively unlinking and freeing nodes from the list until it has + length one, then frees the remaining node. +**/ + +#include "sll.h" + + +void CSLL_destroy(PSLL_ENTRY head) { + PSLL_ENTRY curr, next; + curr = head->Flink; + while( head != curr ) { + next = curr->Flink; + head->Flink = next; + free(curr); + curr = next; + } + free(head); +} + + +void main() { + PSLL_ENTRY head, tail; + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + CSLL_destroy(head); +} diff --git a/test/csll/destroy_test_dangling.c b/test/csll/destroy_test_dangling.c new file mode 100644 index 0000000..fe23627 --- /dev/null +++ b/test/csll/destroy_test_dangling.c @@ -0,0 +1,31 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/** + Create and destroy a cyclic singly-linked list. + + Works by freeing the first node, followed by all others until seeing a + pointer back to the first one. Since this performs a test against a + dangling pointer, it has unspecified behavior according to section 6.2.4.2 + of the ISO C99 standard. +**/ + +#include "sll.h" + + +void destroy(PSLL_ENTRY x) { + PSLL_ENTRY h = x, c; + do { + c = x; + x = x->Flink; + free(c); + } while(x != h); +} + + +void main() { + PSLL_ENTRY head, tail; + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + destroy(head); +} diff --git a/test/csll/fill_walk_drain.c b/test/csll/fill_walk_drain.c new file mode 100644 index 0000000..fa33082 --- /dev/null +++ b/test/csll/fill_walk_drain.c @@ -0,0 +1,43 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + +PSLL_ENTRY newEntry() { return malloc(sizeof(SLL_ENTRY)); } + +void fill(PSLL_ENTRY head) { + while (nondet()) { + PSLL_ENTRY entry = newEntry(); + entry->Flink = head->Flink; + head->Flink = entry; + } +} + +void walk(PSLL_ENTRY head) { + PSLL_ENTRY entry = head->Flink; + while (entry != head) { + entry = entry->Flink; + } +} + +void drain(PSLL_ENTRY head) { + PSLL_ENTRY entry = head->Flink; + while (entry != head) { + PSLL_ENTRY next = entry->Flink; + free(entry); + entry = next; + } +} + +void main() { + PSLL_ENTRY head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink = head; + fill(head); + walk(head); + drain(head); + free(head); +} diff --git a/test/csll/remove.c b/test/csll/remove.c new file mode 100644 index 0000000..0ba6218 --- /dev/null +++ b/test/csll/remove.c @@ -0,0 +1,38 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "csll.h" + + +/* remove any entry of the cyclic list containing head whose Data field is fo, + except head itself */ +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + + prev = head; + entry = head->Flink; + while( entry != head ) { + if( entry->Data == fo ) { + /* remove entry */ + tmp = entry->Flink; + prev->Flink = tmp; + free(entry); + entry = tmp; + } else { + prev = entry; + entry = entry->Flink; + } + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + + CSLL_destroy(head); +} diff --git a/test/csll/remove2.c b/test/csll/remove2.c new file mode 100644 index 0000000..5540cfc --- /dev/null +++ b/test/csll/remove2.c @@ -0,0 +1,38 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* Similar to remove, but does not destroy the list. */ + +#include "csll.h" + + +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + + prev = head; + entry = head->Flink; + while( entry != head ) { + if( entry->Data == fo ) { + /* remove entry */ + tmp = entry->Flink; + prev->Flink = tmp; + free(entry); + entry = tmp; + } else { + prev = entry; + entry = entry->Flink; + } + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + +/* CSLL_destroy(head); */ +} diff --git a/test/csll/remove_for.c b/test/csll/remove_for.c new file mode 100644 index 0000000..79592bd --- /dev/null +++ b/test/csll/remove_for.c @@ -0,0 +1,34 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* + Similar to remove, but using a for loop. + */ +#include "csll.h" + + +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + for( prev = head, entry = head->Flink; + entry != head; + prev = entry, entry = entry->Flink ) { + if( entry->Data == fo ) { + tmp = entry->Flink; + prev->Flink = tmp; + free(entry); + entry = prev; + } + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + + CSLL_destroy(head); +} diff --git a/test/csll/remove_for2.c b/test/csll/remove_for2.c new file mode 100644 index 0000000..32cb875 --- /dev/null +++ b/test/csll/remove_for2.c @@ -0,0 +1,34 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* + Similar to remove2, but using a for loop. + */ +#include "csll.h" + + +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + for( prev = head, entry = head->Flink; + entry != head; + prev = entry, entry = entry->Flink ) { + if( entry->Data == fo ) { + tmp = entry->Flink; + prev->Flink = tmp; + free(entry); + entry = prev; + } + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + + CSLL_destroy(head); +} diff --git a/test/csll/remove_leak.c b/test/csll/remove_leak.c new file mode 100644 index 0000000..340e148 --- /dev/null +++ b/test/csll/remove_leak.c @@ -0,0 +1,38 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "csll.h" + + +/* remove any entry of the cyclic list containing head whose Data field is fo, + except head itself */ +void CSLL_remove(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + + prev = head; + entry = head->Flink; + while(entry != head) { + if (entry->Data == fo) { + /* remove entry */ + tmp = entry->Flink; + prev->Flink = tmp; + /* don't free entry, it gets leaked here */ + entry->Flink = entry; + } else { + prev = entry; + } + entry = entry->Flink; + } +} + + +void main() { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head = SLL_create_seg(nondet(), tail); + tail->Flink = head; + + CSLL_remove(head, 42); + + CSLL_destroy(head); +} diff --git a/test/csll/remove_leak_nd_ret.c b/test/csll/remove_leak_nd_ret.c new file mode 100644 index 0000000..b2b99cd --- /dev/null +++ b/test/csll/remove_leak_nd_ret.c @@ -0,0 +1,81 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "csll.h" + +/* PSLL_ENTRY create_seg(int length, PSLL_ENTRY head) { */ +/* int i; */ +/* PSLL_ENTRY tmp; */ + +/* for(i = 0; i < length; i++) { */ +/* tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); */ +/* tmp->Flink = head; */ +/* head = tmp; */ +/* } */ + +/* return head; */ +/* } */ + + +PSLL_ENTRY find(PSLL_ENTRY head, int fo) { + PSLL_ENTRY prev, entry, tmp; + +/* for (prev = head, entry = head->Flink; */ +/* entry != head; */ +/* prev = entry, entry = entry->Flink) { */ + + prev = head; + entry = head->Flink; + while(entry != head) { + if (entry->Data == fo) { + /* remove entry */ + tmp = entry->Flink; + prev->Flink = tmp; + /* don't free entry, it gets leaked here */ + + if (nondet()) { + return entry; + } else { + entry->Flink = entry; + } + } else { + prev = entry; + } + entry = entry->Flink; + } + + return NULL; +} + +void main() { + PSLL_ENTRY head, tail, mark; + int i; + PSLL_ENTRY tmp; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + +/* head = create_seg(4, tail); */ + head = tail; + for(i = 0; i < 4; i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + +/* mark = cons(42, head); */ + +/* /\* head = create_seg(2, mark); *\/ */ +/* head = mark; */ +/* for(i = 0; i < 2; i++) { */ +/* tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); */ +/* tmp->Flink = head; */ +/* head = tmp; */ +/* } */ + + tail->Flink = head; + +/* print_csll(head); */ + + find(head, 42); + +/* print_csll(head); */ +} diff --git a/test/dev/frec.c b/test/dev/frec.c new file mode 100644 index 0000000..d3681cf --- /dev/null +++ b/test/dev/frec.c @@ -0,0 +1,14 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +// frec not inlineable: calls itself. +void frec (int x) +{ +/* int x = y; */ + if (x==0) return; + else frec(x-1); +} + +void main() +{ + frec(99); +} diff --git a/test/dev/irreducible.c b/test/dev/irreducible.c new file mode 100644 index 0000000..a6f5e24 --- /dev/null +++ b/test/dev/irreducible.c @@ -0,0 +1,22 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +void main() { + int x, y; + + x++; + if(x / 2) { + L0: + if(x <= 0) goto L3; + x--; + goto L1; + } else { + L1: + y++; + goto L0; + } + L3: + + return; +} diff --git a/test/dev/straight.c b/test/dev/straight.c new file mode 100644 index 0000000..ca9c530 --- /dev/null +++ b/test/dev/straight.c @@ -0,0 +1,21 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +typedef struct _LIST_ENTRY { + struct _LIST_ENTRY *Flink; + struct _LIST_ENTRY *Blink; +} LIST_ENTRY, *PLIST_ENTRY; + +void main(void) { + int length = 10; + PLIST_ENTRY head, tmp; + + head = NULL; + tmp = (PLIST_ENTRY)malloc(sizeof(LIST_ENTRY)); + tmp->Flink = head; + head = tmp; + tmp = tmp->Flink; + + return; +} diff --git a/test/dev/straight_func.c b/test/dev/straight_func.c new file mode 100644 index 0000000..d0bacf1 --- /dev/null +++ b/test/dev/straight_func.c @@ -0,0 +1,48 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + + +typedef struct _LIST_ENTRY { + struct _LIST_ENTRY *Flink; + struct _LIST_ENTRY *Blink; +} LIST_ENTRY, *PLIST_ENTRY; + +PLIST_ENTRY create(int length) { +/* int i; */ + PLIST_ENTRY head, tmp; + + head = NULL; +/* for(i = 0; i < length; i++) { */ + tmp = (PLIST_ENTRY)malloc(sizeof(LIST_ENTRY)); + tmp->Flink = head; + head = tmp; +/* } */ + return head; +} + +void traverse(PLIST_ENTRY head) { + PLIST_ENTRY tmp = head; + + while(tmp != NULL) { + tmp = tmp->Flink ; + } +} + +void destroy(PLIST_ENTRY head) { + PLIST_ENTRY t, c = head; + +/* while(c != NULL) { */ + t = c; + c = c->Flink; + free(t); +} + +void main(void) { + int length = 10; + PLIST_ENTRY head; + head = create(length); + traverse(head); + destroy(head); + return; +} diff --git a/test/kmdf/1394.h b/test/kmdf/1394.h new file mode 100644 index 0000000..8e9443a --- /dev/null +++ b/test/kmdf/1394.h @@ -0,0 +1,122 @@ +/****************************************************************************** + * File: 1394.h (device driver?) + * Moved these definitions out from the main harness file, as they + * conflicted with definitions needed by toaster. This file should only + * be included by the 1394 test drivers. + ******************************************************************************/ + +#define POOLTAG_1394 4931 + +#define IOCTL_SET_LOCAL_HOST_INFORMATION \ + ((0x00000022 << 16) | ((0x0800 + 30) << 14) | (0 << 2) | (0)) + +// Copied from 1394samp.h. +typedef struct _DEVICE_EXTENSION { + PDEVICE_OBJECT PortDeviceObject; + PDEVICE_OBJECT PhysicalDeviceObject; + PDEVICE_OBJECT StackDeviceObject; + + WDFDEVICE WdfDevice; + WDFIOTARGET StackIoTarget; + WDFIOTARGET PortDeviceIoTarget; + + WDFQUEUE IoctlQueue; + + WDFQUEUE BusResetRequestsQueue; + + WDFSPINLOCK CromSpinLock; + WDFSPINLOCK AsyncSpinLock; + WDFSPINLOCK IsochSpinLock; + WDFSPINLOCK IsochResourceSpinLock; + +/* ULONG GenerationCount; */ + LIST_ENTRY CromData; + LIST_ENTRY AsyncAddressData; + LIST_ENTRY IsochDetachData; + LIST_ENTRY IsochResourceData; + +} DEVICE_EXTENSION, *PDEVICE_EXTENSION; + +WDF_DECLARE_CONTEXT_TYPE_WITH_NAME(DEVICE_EXTENSION, GetDeviceContext) + +// +// This is used to keep track of dynamic crom calls. +// +typedef struct _CROM_DATA { + LIST_ENTRY CromList; + HANDLE hCromData; + PVOID Buffer; + PMDL pMdl; +} CROM_DATA, *PCROM_DATA; + +// Review: the corresponding Patn allocs CromData->_ [...;Buffer:B; pMdl:pM] * B->_ * pM->_. + +// +// This is used to store data for each async address range. +// +typedef struct _ASYNC_ADDRESS_DATA { + LIST_ENTRY AsyncAddressList; + PDEVICE_EXTENSION DeviceExtension; + PVOID Buffer; + ULONG nLength; + ULONG nAddressesReturned; + PADDRESS_RANGE AddressRange; + HANDLE hAddressRange; + PMDL pMdl; +} ASYNC_ADDRESS_DATA, *PASYNC_ADDRESS_DATA; + +// Review: the corresponding Patn allocs AsyncAddrData->[...;Buffer:B;AddressRange:A;pMdl:pM] * B->_ * A->_ * pM->_. + + +// +// This is used to store data needed when calling IsochDetachBuffers. +// We need to store this data seperately for each call to IsochAtfrtachBuffers. +// +typedef struct _ISOCH_DETACH_DATA { + LIST_ENTRY IsochDetachList; + PDEVICE_EXTENSION DeviceExtension; +/* PISOCH_DESCRIPTOR IsochDescriptor; */ +/* WDFREQUEST Request; */ +/* PIRP newIrp; */ +/* PIRB DetachIrb; */ +/* PIRB AttachIrb; */ +/* NTSTATUS AttachStatus; */ +/* KTIMER Timer; */ +/* KDPC TimerDpc; */ +/* HANDLE hResource; */ +/* ULONG numIsochDescriptors; */ +/* ULONG outputBufferLength; */ +/* ULONG bDetach; */ +} ISOCH_DETACH_DATA, *PISOCH_DETACH_DATA; + +/* Review */ +/* The corresponding patn allocs */ +/* IsochDetachData->[...;DeviceExtension:SL_Context; IsochDescriptor:pIsochD; newIrp:pIrp; DetachIrb:d; AttachIrb:a] * */ +/* SL_Context->_ (shared by all isochdetachdatas) * */ +/* pIsochD->_ * pIrp->_ * */ +/* (d=0 \/ d->_) * (a=0 \/ a->_) */ + +// +// This is used to store allocated isoch resources. +// We use this information in case of a surprise removal. +// +typedef struct _ISOCH_RESOURCE_DATA { + LIST_ENTRY IsochResourceList; + HANDLE hResource; +} ISOCH_RESOURCE_DATA, *PISOCH_RESOURCE_DATA; + + +/* void t1394_EvtDeviceSelfManagedIoCleanup(PDEVICE_EXTENSION deviceExtension) */ +/* { */ +/* PLIST_ENTRY listEntry ; */ +/* while (!IsListEmpty(&deviceExtension->CromData)) { */ +/* PCROM_DATA CromData; */ +/* listEntry = RemoveHeadList(&deviceExtension->CromData); */ +/* CromData = CONTAINING_RECORD(listEntry, CROM_DATA, CromList); */ +/* if (CromData) { */ + /* //if (CromData->Buffer) ExFreePool(CromData->Buffer); */ + /* //if (CromData->pMdl) IoFreeMdl(CromData->pMdl); */ +/* ExFreePool(CromData); */ +/* } */ +/* } */ +/* } */ diff --git a/test/kmdf/1394/CromData_trace.c b/test/kmdf/1394/CromData_trace.c new file mode 100644 index 0000000..0c26389 --- /dev/null +++ b/test/kmdf/1394/CromData_trace.c @@ -0,0 +1,1246 @@ +/****************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + t1394_SetLocalHostProperties procedure. + + ******************************************************************************/ + +#include "harness.h" +#include "1394.h" +#include "common.h" + +NTSTATUS t1394_SubmitIrpSynch(WDFIOTARGET IoTarget, WDFREQUEST Request, PIRB Irb) +{ + int x; + if (x) { + return STATUS_SUCCESS; + } else { + return STATUS_UNSUCCESSFUL; + } +} + +NTSTATUS +t1394_SetLocalHostProperties( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDFREQUEST Request, + /*IN*/ ULONG nLevel, + /*IN*/ PVOID Information + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension = GetDeviceContext(Device); + PIRB pIrb = NULL; + PSET_LOCAL_HOST_PROPS3 R0_SetLocalHostProps3 = NULL; + PCROM_DATA CromData = NULL; + PLIST_ENTRY listHead, thisEntry; + + //ENTER("t1394_SetLocalHostProperties"); + + // allocate irb + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + if (!pIrb) { + + // TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } // if + + + + RtlZeroMemory (pIrb, sizeof (IRB)); + pIrb->FunctionNumber = REQUEST_SET_LOCAL_HOST_PROPERTIES; + pIrb->Flags = 0; + + // SI: writes to union broken + // pIrb->u.SetLocalHostProperties.nLevel = nLevel; + + // TRACE(TL_TRACE, ("nLevel = 0x%x\n", nLevel)); + // TRACE(TL_TRACE, ("Information = 0x%x\n", Information)); + + if (nLevel == SET_LOCAL_HOST_PROPERTIES_GAP_COUNT) { + + PSET_LOCAL_HOST_PROPS2 SetLocalHostProps2; + + SetLocalHostProps2 = (PSET_LOCAL_HOST_PROPS2)Information; + + // TRACE(TL_TRACE, ("GapCountLowerBound = 0x%x\n", SetLocalHostProps2->GapCountLowerBound)); + // SI: writes to union broken + // pIrb->u.SetLocalHostProperties.Information = Information; + } + else if (nLevel == SET_LOCAL_HOST_PROPERTIES_MODIFY_CROM) { + + PSET_LOCAL_HOST_PROPS3 SetLocalHostProps3; + + SetLocalHostProps3 = (PSET_LOCAL_HOST_PROPS3)Information; + + // TRACE(TL_TRACE, ("fulFlags = 0x%x\n", SetLocalHostProps3->fulFlags)); + // TRACE(TL_TRACE, ("hCromData = 0x%x\n", SetLocalHostProps3->hCromData)); + // TRACE(TL_TRACE, ("nLength = 0x%x\n", SetLocalHostProps3->nLength)); + + // since we need to create a mdl, we'll create another setlocalhostprops3 + // and pass that down to the bus driver + R0_SetLocalHostProps3 = ExAllocatePoolWithTag(NonPagedPool, + sizeof(SET_LOCAL_HOST_PROPS3), + POOLTAG_1394); + + if (!R0_SetLocalHostProps3) { + + // TRACE(TL_ERROR, ("Failed to allocate R0_SetLocalHostProps3!\n")); + if (pIrb) + ExFreePool(pIrb); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } // if + + // TRACE(TL_TRACE, ("R0_SetLocalHostProps3 = 0x%x\n", R0_SetLocalHostProps3)); + + // copy over the contents... + RtlCopyMemory( R0_SetLocalHostProps3, + SetLocalHostProps3, + sizeof(SET_LOCAL_HOST_PROPS3) + ); + + // branch, depending if we are adding or removing + if (R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_ADD_CROM_DATA) { + + // we are adding an entry. let's get our crom data struct... + CromData = ExAllocatePoolWithTag(NonPagedPool, + sizeof(CROM_DATA), + POOLTAG_1394); + + if (!CromData) { + + // TRACE(TL_ERROR, ("Failed to allocate CromData!\n")); + if (pIrb) + ExFreePool(pIrb); + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } + + // let's allocate our buffer... + CromData->Buffer = ExAllocatePoolWithTag(NonPagedPool, + R0_SetLocalHostProps3->nLength, + POOLTAG_1394); + + // TRACE(TL_TRACE, ("CromData->Buffer = 0x%x\n", CromData->Buffer)); + + if (!CromData->Buffer) { + + // TRACE(TL_ERROR, ("Failed to allocate CromData->Buffer!\n")); + if (pIrb) + ExFreePool(pIrb); + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + + if (CromData) + ExFreePool(CromData); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + } + + // copy over contents (mdl == ring 3 buffer) + RtlCopyMemory(CromData->Buffer, + &SetLocalHostProps3->Mdl, + SetLocalHostProps3->nLength); + + R0_SetLocalHostProps3->Mdl = IoAllocateMdl (CromData->Buffer, + R0_SetLocalHostProps3->nLength, + FALSE, + FALSE, + NULL); + if(R0_SetLocalHostProps3->Mdl == NULL) { + + // TRACE(TL_ERROR, ("Failed to allocate mdl for CromData->Buffer!\n")); + if (pIrb) + ExFreePool(pIrb); + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + + if (CromData) + ExFreePool(CromData); + + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_SetLocalHostProperties; + + } + MmBuildMdlForNonPagedPool(R0_SetLocalHostProps3->Mdl); + + // TRACE(TL_TRACE, ("Mdl = 0x%x\n", R0_SetLocalHostProps3->Mdl)); + } + else if (SetLocalHostProps3->fulFlags == SLHP_FLAG_REMOVE_CROM_DATA) { + + // TRACE(TL_TRACE, ("hCromData = 0x%x\n", R0_SetLocalHostProps3->hCromData)); + } + + // SI: writes to union broken + // pIrb->u.SetLocalHostProperties.Information = (PVOID)R0_SetLocalHostProps3; + } + + ntStatus = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, Request, pIrb); + + if (!NT_SUCCESS(ntStatus)) { + + if (nLevel == SET_LOCAL_HOST_PROPERTIES_MODIFY_CROM) { + + if (R0_SetLocalHostProps3 && + R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_ADD_CROM_DATA) { + + if (R0_SetLocalHostProps3->Mdl) + IoFreeMdl(R0_SetLocalHostProps3->Mdl); + + if (CromData) { + if (CromData->Buffer) { + ExFreePool(CromData->Buffer); + } + ExFreePool(CromData); + } + } + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + } + + // TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", ntStatus)); + } + else { + + if (nLevel == SET_LOCAL_HOST_PROPERTIES_MODIFY_CROM) { + // + // branch, depending if we are adding or removing + // + if (R0_SetLocalHostProps3 && + R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_ADD_CROM_DATA) { + + PSET_LOCAL_HOST_PROPS3 SetLocalHostProps3; + + SetLocalHostProps3 = Information; + SetLocalHostProps3->hCromData = R0_SetLocalHostProps3->hCromData; + + // TRACE(TL_TRACE, ("hCromData = 0x%x\n", SetLocalHostProps3->hCromData)); + + if (CromData) { + + CromData->hCromData = SetLocalHostProps3->hCromData; + CromData->pMdl = R0_SetLocalHostProps3->Mdl; + + // need to add to our list... + + WdfSpinLockAcquire(deviceExtension->CromSpinLock); + InsertHeadList(&deviceExtension->CromData, &CromData->CromList); + + WdfSpinLockRelease(deviceExtension->CromSpinLock); + } + } + else if (R0_SetLocalHostProps3 && + R0_SetLocalHostProps3->fulFlags == SLHP_FLAG_REMOVE_CROM_DATA) { + + // have to find our struct... + + WdfSpinLockAcquire(deviceExtension->CromSpinLock); + + listHead = &deviceExtension->CromData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + CromData = NULL, thisEntry = thisEntry->Flink) + { + CromData = CONTAINING_RECORD(thisEntry, CROM_DATA, CromList); + if (CromData->hCromData == R0_SetLocalHostProps3->hCromData) { + RemoveEntryList(&CromData->CromList); + break; + } + } + + WdfSpinLockRelease(deviceExtension->CromSpinLock); + + if (CromData) { + + if (CromData->Buffer) + ExFreePool(CromData->Buffer); + + if (CromData->pMdl) + IoFreeMdl(CromData->pMdl); + + ExFreePool(CromData); + } + } + + if (R0_SetLocalHostProps3) + ExFreePool(R0_SetLocalHostProps3); + } + } + + +Exit_SetLocalHostProperties: + + if (pIrb) + { + ExFreePool(pIrb); + } + + + //EXIT("t1394_SetLocalHostProperties", ntStatus); + return(ntStatus); +} // t1394_SetLocalHostProperties + + +/****************************************************************************** + + WDF_IO_QUEUE_IO_DEVICE_CONTROL + + The IOCTL_SET_LOCAL_HOST_INFORMATION part of EvtIoDeviceControl. + Tranform the Request into a SetLocalHostInformation, and pass it down to + the local t1394_SetLocalHostProperties procedure. + + ******************************************************************************/ +VOID +t1394_EvtIoDeviceControl( + /*IN*/WDFQUEUE Queue, + /*IN*/WDFREQUEST Request, + /*IN*/size_t OutputBufferLength, + /*IN*/size_t InputBufferLength, + /*IN*/ULONG IoControlCode + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension; + PVOID ioBuffer = NULL; + WDFDEVICE device; + size_t bufLength; + + //ENTER("t1394_EvtIoDeviceControl"); + // TRACE(TL_TRACE, ("Request = 0x%p\n", Request)); + + device = WdfIoQueueGetDevice(Queue); + deviceExtension = GetDeviceContext(device); + + // + // Since all the IOCTLs handled here are buffered, WdfRequestRetrieveOutputBuffer & + // WdfRequestRetrieveInputBuffer return the same buffer pointer. + // So make sure you read all the information you need from + // the buffer before you write to it. Also requiredLength of the buffer vary from + // ioctl to ioctl, so we will pretend that we need zero length buffer and do the lenght + // check later in the specific ioct case. + // + ntStatus = WdfRequestRetrieveInputBuffer(Request, 0, &ioBuffer, &bufLength); + if( !NT_SUCCESS(ntStatus) || ioBuffer == NULL) { + // TRACE(TL_ERROR, ("WdfRequestRetrieveInputBuffer failed 0x%x\n", ntStatus)); + WdfRequestComplete(Request, ntStatus); + return; + } + + + switch (IoControlCode) { + + case IOCTL_SET_LOCAL_HOST_INFORMATION: + { + PSET_LOCAL_HOST_INFORMATION SetLocalHostInformation; + + // TRACE(TL_TRACE, ("IOCTL_SET_LOCAL_HOST_INFORMATION\n")); + + if (InputBufferLength < sizeof(SET_LOCAL_HOST_INFORMATION)) { + + ntStatus = STATUS_BUFFER_TOO_SMALL; + } + else { + + SetLocalHostInformation = (PSET_LOCAL_HOST_INFORMATION)ioBuffer; + + if (InputBufferLength < (sizeof(SET_LOCAL_HOST_INFORMATION) + + SetLocalHostInformation->ulBufferSize)) { + + ntStatus = STATUS_BUFFER_TOO_SMALL; + } + else { + + ntStatus = t1394_SetLocalHostProperties( device, + Request, + SetLocalHostInformation->nLevel, + (PVOID)&SetLocalHostInformation->Information + ); + + if (NT_SUCCESS(ntStatus)) + WdfRequestSetInformation(Request, OutputBufferLength); + } + } + } + break; // IOCTL_SET_LOCAL_HOST_INFORMATION + + default: + // TRACE(TL_ERROR, ("Invalid ioControlCode = 0x%x\n", IoControlCode)); + ntStatus = STATUS_INVALID_PARAMETER; + break; // default + + } // switch + + + // only complete if the device is there + if (ntStatus != STATUS_PENDING) { + + WdfRequestComplete(Request, ntStatus); + } + + //EXIT("t1394_IoControl", ntStatus); + return ; +} // t1394_EvtIoDeviceControl + + +/****************************************************************************** + + WDF_DEVICE_SEFL_MANAGED_IO_CLEANUP + (Only the CromData cleanup part of it) + + ******************************************************************************/ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( + /*IN*/ WDFDEVICE Device + ) +/*++ + +Routine Description: + + EvtDeviceSelfManagedIoCleanup is called by the Framework when the device is + being torn down, either in response to IRP_MN_REMOVE_DEVICE or + IRP_MN_SURPRISE_REMOVE_DEVICE. It will be called only once. Its job is to + stop all outstanding I/O in the driver that the Framework is not managing. + +Arguments: + + Device - Handle to a framework device object. + +Return Value: + + None + +--*/ +{ + PDEVICE_EXTENSION deviceExtension; + PLIST_ENTRY listEntry; + + //ENTER("t1394_PnpRemoveDevice"); + + deviceExtension = GetDeviceContext(Device); + + // TRACE(TL_WARNING, ("Removing 1394VDEV.SYS.\n")); + + // lets free up any crom data structs we've allocated... + + WdfSpinLockAcquire(deviceExtension->CromSpinLock); + + while (!IsListEmpty(&deviceExtension->CromData)) { + + PCROM_DATA CromData; + + // get struct off list + + listEntry = RemoveHeadList(&deviceExtension->CromData); + CromData = CONTAINING_RECORD(listEntry, CROM_DATA, CromList); + + // need to free up everything associated with this allocate... + if (CromData) + { + if (CromData->Buffer) { + ExFreePool(CromData->Buffer); + } + if (CromData->pMdl) { + IoFreeMdl(CromData->pMdl); + } + // we already checked CromData + ExFreePool(CromData); + } + } + + + WdfSpinLockRelease(deviceExtension->CromSpinLock); + +/* // lets free up any allocated addresses and deallocate all */ +/* // memory associated with them... */ + +/* WdfSpinLockAcquire(deviceExtension->AsyncSpinLock); */ + +/* while (!IsListEmpty(&deviceExtension->AsyncAddressData)) { */ + +/* PASYNC_ADDRESS_DATA AsyncAddressData; */ + +/* // get struct off list */ +/* listEntry = RemoveHeadList(&deviceExtension->AsyncAddressData); */ + +/* AsyncAddressData = CONTAINING_RECORD(listEntry, ASYNC_ADDRESS_DATA, */ +/* AsyncAddressList); */ + +/* // need to free up everything associated with this allocate... */ +/* if (AsyncAddressData->pMdl) */ +/* IoFreeMdl(AsyncAddressData->pMdl); */ + +/* if (AsyncAddressData->Buffer) */ +/* ExFreePool(AsyncAddressData->Buffer); */ + +/* if (AsyncAddressData->AddressRange) */ +/* ExFreePool(AsyncAddressData->AddressRange); */ + +/* if (AsyncAddressData) */ +/* ExFreePool(AsyncAddressData); */ +/* } */ + + +/* WdfSpinLockRelease(deviceExtension->AsyncSpinLock); */ + +/* // */ +/* // Free up any attached isoch buffers */ +/* // Note: There are known bugs in this code path */ +/* // */ +/* WHILE (TRUE) { */ + +/* WdfSpinLockAcquire(deviceExtension->IsochSpinLock); */ + +/* if (!IsListEmpty(&deviceExtension->IsochDetachData)) { */ + +/* PISOCH_DETACH_DATA IsochDetachData; */ + +/* IsochDetachData = (PISOCH_DETACH_DATA) */ +/* RemoveHeadList(&deviceExtension->IsochDetachData); */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: IsochDetachData = 0x%x\n", */ +/* IsochDetachData)); */ + +/* KeCancelTimer(&IsochDetachData->Timer); */ + +/* WdfSpinLockRelease(deviceExtension->IsochSpinLock); */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: IsochDetachData->Irp = 0x%x\n", */ +/* IsochDetachData->Request)); */ + +/* // need to save the status of the attach */ +/* // we'll clean up in the same spot for success's and timeout's */ +/* IsochDetachData->AttachStatus = STATUS_SUCCESS; */ + +/* // detach no matter what... */ +/* IsochDetachData->bDetach = TRUE; */ + +/* t1394_IsochCleanup(IsochDetachData); */ +/* } */ +/* else { */ + +/* WdfSpinLockRelease(deviceExtension->IsochSpinLock); */ +/* break; */ +/* } */ +/* } */ + +/* // */ +/* // Remove any isoch resource data */ +/* // */ +/* WHILE (TRUE) { */ + +/* WdfSpinLockAcquire(deviceExtension->IsochResourceSpinLock); */ + +/* if (!IsListEmpty(&deviceExtension->IsochResourceData)) { */ + +/* PISOCH_RESOURCE_DATA IsochResourceData = NULL; */ + +/* listEntry = RemoveHeadList(&deviceExtension->CromData); */ + +/* IsochResourceData = CONTAINING_RECORD(listEntry, */ +/* ISOCH_RESOURCE_DATA, */ +/* IsochResourceList); */ + +/* WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: IsochResourceData = 0x%x\n", */ +/* IsochResourceData)); */ + +/* if (IsochResourceData) { */ + +/* PIRB pIrb; */ +/* WDFREQUEST request; */ +/* NTSTATUS status; */ + +/* // TRACE(TL_TRACE, ("Surprise Removal: Freeing hResource = 0x%x\n", */ +/* IsochResourceData->hResource)); */ + +/* status = WdfRequestCreate( */ +/* WDF_NO_OBJECT_ATTRIBUTES, */ +/* deviceExtension->StackIoTarget, */ +/* &request); */ + +/* if (!NT_SUCCESS(status)) { */ +/* // TRACE(TL_ERROR, ("Failed to allocate request %x\n", status)); */ +/* } */ +/* else { */ + +/* pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); */ + +/* if (!pIrb) { */ + +/* WdfObjectDelete(request); */ + +/* // TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ +/* } */ +/* else { */ + +/* RtlZeroMemory (pIrb, sizeof (IRB)); */ +/* pIrb->FunctionNumber = REQUEST_ISOCH_FREE_RESOURCES; */ +/* pIrb->Flags = 0; */ +/* pIrb->u.IsochFreeResources.hResource = IsochResourceData->hResource; */ + +/* status = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, request, pIrb); */ + +/* if (!NT_SUCCESS(status)) { */ + +/* // TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", status)); */ +/* } */ + +/* ExFreePool(pIrb); */ +/* WdfObjectDelete(request); */ +/* } */ +/* } */ +/* } */ +/* } */ +/* else { */ + + +/* WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); */ +/* break; */ +/* } */ +/* } */ + + //EXIT("t1394_PnpRemoveDevice", STATUS_SUCCESS); + +} // t1394_PnpRemoveDevice + + + +/****************************************************************************** + + WDF_DRIVER_DEVICE_ADD + + ******************************************************************************/ + + +NTSTATUS +t1394_EvtPrepareHardware ( + WDFDEVICE Device, + WDFCMRESLIST Resources, + WDFCMRESLIST ResourcesTranslated + ) +/*++ + +Routine Description: + + EvtDeviceStart event callback performs operations that are necessary + to make the driver's device operational. The framework calls the driver's + EvtDeviceStart callback when the PnP manager sends an IRP_MN_START_DEVICE + request to the driver stack. + +Arguments: + + Device - Handle to a framework device object. + +Return Value: + + WDF status code + +--*/ +{ + NTSTATUS status = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension; + +/* UNREFERENCED_PARAMETER(Resources); */ +/* UNREFERENCED_PARAMETER(ResourcesTranslated); */ + +/* VERIFY_IS_IRQL_PASSIVE_LEVEL(); */ + +/* TRACE(TL_TRACE, ( "--> t1394_EvtPrepareHardware\n")); */ + +/* deviceExtension = GetDeviceContext(Device); */ + +/* status = t1394_BusResetNotification( Device, */ +/* NULL, */ +/* REGISTER_NOTIFICATION_ROUTINE ); */ + +/* TRACE(TL_TRACE, ( "<-- t1394_EvtPrepareHardware\n")); */ + + return status; +} + +NTSTATUS +t1394_EvtReleaseHardware( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDFCMRESLIST ResourcesTranslated + ) +/*++ + +Routine Description: + + EvtDeviceReleaseHardware is called by the framework whenever the PnP manager + is revoking ownership of our resources. This may be in response to either + IRP_MN_STOP_DEVICE or IRP_MN_REMOVE_DEVICE. The callback is made before + passing down the IRP to the lower driver. + + In this callback, do anything necessary to free those resources. + +Arguments: + + Device - Handle to a framework device object. + +Return Value: + + NTSTATUS - Failures will be logged, but not acted on. + +--*/ +{ + NTSTATUS status; + +/* UNREFERENCED_PARAMETER(ResourcesTranslated); */ + +/* VERIFY_IS_IRQL_PASSIVE_LEVEL(); */ + +/* TRACE(TL_TRACE, ( "--> t1394_EvtReleaseHardware\n")); */ + +/* status = t1394_BusResetNotification(Device, */ +/* NULL, */ +/* DEREGISTER_NOTIFICATION_ROUTINE ); */ + +/* TRACE(TL_TRACE, ( "<-- t1394_EvtReleaseHardware\n")); */ + + return status; +} + +NTSTATUS +t1394_EvtDeviceD0Entry( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDF_POWER_DEVICE_STATE PreviousState + ) +/*++ + +Routine Description: + + EvtDeviceD0Entry event callback must perform any operations that are + necessary before the specified device is used. It will be called every + time the hardware needs to be (re-)initialized. This includes after + IRP_MN_START_DEVICE, IRP_MN_CANCEL_STOP_DEVICE, IRP_MN_CANCEL_REMOVE_DEVICE, + IRP_MN_SET_POWER-D0. + + This function runs at PASSIVE_LEVEL, though it is generally not paged. A + driver can optionally make this function pageable if DO_POWER_PAGABLE is set. + + Even if DO_POWER_PAGABLE isn't set, this function still runs at + PASSIVE_LEVEL. In this case, though, the function absolutely must not do + anything that will cause a page fault. + +Arguments: + + Device - Handle to a framework device object. + + PreviousState - Device power state which the device was in most recently. + If the device is being newly started, this will be + PowerDeviceUnspecified. + +Return Value: + + NTSTATUS + +--*/ +{ + NTSTATUS status = STATUS_SUCCESS; + +/* UNREFERENCED_PARAMETER(PreviousState); */ + +/* TRACE(TL_TRACE, ( */ +/* "-->t1394_EvtDeviceD0Entry - coming from %s\n", */ +/* DbgDevicePowerString(PreviousState))); */ + +/* // update the generation count */ +/* t1394_UpdateGenerationCount(Device); */ + +/* TRACE(TL_TRACE, ( "<--t1394_EvtDeviceD0Entry\n")); */ + + return status; +} + + +NTSTATUS +t1394_EvtDeviceD0Exit( + /*IN*/ WDFDEVICE Device, + /*IN*/ WDF_POWER_DEVICE_STATE TargetState + ) +/*++ + +Routine Description: + + EvtDeviceD0Exit event callback must perform any operations that are + necessary before the specified device is moved out of the D0 state. If the + driver needs to save hardware state before the device is powered down, then + that should be done here. + + This function runs at PASSIVE_LEVEL, though it is generally not paged. A + driver can optionally make this function pageable if DO_POWER_PAGABLE is set. + + Even if DO_POWER_PAGABLE isn't set, this function still runs at + PASSIVE_LEVEL. In this case, though, the function absolutely must not do + anything that will cause a page fault. + +Arguments: + + Device - Handle to a framework device object. + + TargetState - Device power state which the device will be put in once this + callback is complete. + +Return Value: + + NTSTATUS + +--*/ +{ + +/* UNREFERENCED_PARAMETER(Device); */ +/* UNREFERENCED_PARAMETER(TargetState); */ + +/* TRACE(TL_TRACE, ( */ +/* "-->t1394_EvtDeviceD0Exit - moving to %s\n", */ +/* DbgDevicePowerString(TargetState))); */ + + +/* TRACE(TL_TRACE, ( "<--t1394_EvtDeviceD0Exit\n")); */ + + return STATUS_SUCCESS; +} + + +NTSTATUS +t1394_EvtDeviceAdd( + /*IN*/WDFDRIVER Driver, + /*IN*/PWDFDEVICE_INIT DeviceInit + ) +/*++ +Routine Description: + + EvtDeviceAdd is called by the framework in response to AddDevice + call from the PnP manager. + +Arguments: + + Driver - Handle to a framework driver object created in DriverEntry + + DeviceInit - Pointer to a framework-allocated WDFDEVICE_INIT structure. + +Return Value: + + NTSTATUS + +--*/ +{ + NTSTATUS status = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension; + PNODE_DEVICE_EXTENSION pNodeExt; + WDF_PNPPOWER_EVENT_CALLBACKS pnpPowerCallbacks; + WDF_OBJECT_ATTRIBUTES fdoAttributes,lockAttributes; + WDFDEVICE device; + WDF_DEVICE_PNP_CAPABILITIES pnpCaps; + WDF_IO_QUEUE_CONFIG ioQueueConfig; + WDF_IO_TARGET_OPEN_PARAMS openParams; + + //UNREFERENCED_PARAMETER(Driver); + + //ENTER("t1394_PnpAddDevice"); + + // + // Zero out the PnpPowerCallbacks structure. + // + WDF_PNPPOWER_EVENT_CALLBACKS_INIT(&pnpPowerCallbacks); + + // + // Set Callbacks for any of the functions we are interested in. + // If no callback is set, Framework will take the default action + // by itself. + + // + // These two callbacks set up and tear down hardware state, + // specifically that which only has to be done once. + // + + pnpPowerCallbacks.EvtDevicePrepareHardware = t1394_EvtPrepareHardware; + pnpPowerCallbacks.EvtDeviceReleaseHardware = t1394_EvtReleaseHardware; + + pnpPowerCallbacks.EvtDeviceSelfManagedIoCleanup = + t1394_EvtDeviceSelfManagedIoCleanup; + + pnpPowerCallbacks.EvtDeviceD0Entry = t1394_EvtDeviceD0Entry; + pnpPowerCallbacks.EvtDeviceD0Exit = t1394_EvtDeviceD0Exit; + + // + // Register the PnP and power callbacks. Power policy related callbacks + // will be registered// later in SotwareInit. + // + WdfDeviceInitSetPnpPowerEventCallbacks(DeviceInit, &pnpPowerCallbacks); + if ( !NT_SUCCESS(status)) { + //TRACE(TL_ERROR, ("WdfDeviceInitSetPnpPowerEventCallbacks failed %x\n", + // status)); + return status; + } + + WdfDeviceInitSetExclusive(DeviceInit, FALSE); + + // + // Specify the size and type of device context. + // + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&fdoAttributes, DEVICE_EXTENSION); + + status = WdfDeviceCreate(&DeviceInit, &fdoAttributes, &device); + + if ( !NT_SUCCESS(status)) { + //TRACE(TL_ERROR, ("WdfDeviceInitialize failed %x\n", status)); + return status; + } + + + deviceExtension = GetDeviceContext (device); + deviceExtension->WdfDevice = device; + + //TRACE(TL_TRACE, ("PDO(0x%p) FDO(0x%p), Lower(0x%p) DevExt (0x%p)\n", + // WdfDeviceWdmGetPhysicalDevice (device), + // WdfDeviceWdmGetDeviceObject (device), + // WdfDeviceWdmGetAttachedDevice(device), + // deviceExtension)); + + // + // Tell the Framework that this device will need an interface so that + // application can interact with it. + // + + status = WdfDeviceCreateDeviceInterface( + device, +#if defined(_1394VDEV_DRIVER_) + (LPGUID) &GUID_1394VDEV, +#else + (LPGUID) &GUID_1394DIAG, +#endif + NULL + ); + + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfDeviceCreateDeviceInterface failed %x\n", status)); + return status; + } + + // + // Tell the framework to set the SurpriseRemovalOK in the DeviceCaps so + // that you don't get the popup in usermode (on Win2K) when you surprise + // remove the device. + // + WDF_DEVICE_PNP_CAPABILITIES_INIT(&pnpCaps); + pnpCaps.SurpriseRemovalOK = WdfTrue; + + WdfDeviceSetPnpCapabilities(device, &pnpCaps); + + // save the device object we created as our physical device object + deviceExtension->PhysicalDeviceObject = + WdfDeviceWdmGetPhysicalDevice (device); + + if (deviceExtension->PhysicalDeviceObject == NULL) { + //TRACE(TL_ERROR, ("WdfDeviceWdmGetPhysicalDevice: NULL DeviceObject\n")); + return STATUS_UNSUCCESSFUL; + } + + // + // This is our default IoTarget representing the deviceobject + // we are attached to. + // + deviceExtension->StackIoTarget = WdfDeviceGetIoTarget(device); + deviceExtension->StackDeviceObject = WdfDeviceWdmGetAttachedDevice(device); + + if (deviceExtension->StackDeviceObject == NULL) { + //TRACE(TL_ERROR, ("WdfDeviceWdmGetAttachedDevice: NULL DeviceObject\n")); + return STATUS_UNSUCCESSFUL; + } + + // Patch: this code is not in DDK 7600.16385.1 { + // + // Get the port device object from the passed in PhysicalDeviceObject + // created by the 1394 stack for us. + // Note: we can't use the top of the stack and get its device extension + // in case there is a filter driver between us and our PDO. + // + //pNodeExt = WdfDeviceWdmGetPhysicalDevice(device)->DeviceExtension; + //deviceExtension->PortDeviceObject = pNodeExt->PortDeviceObject; + // Patch: this code is not in DDK 7600.16385.1 } + + //TRACE(TL_TRACE, ("PortDeviceObject = 0x%x\n", + // deviceExtension->PortDeviceObject)); + + // + // Create a automanaged queue for dispatching ioctl requests. + // All other requests are automatically failed by the framework. + // By creating an automanaged queue we don't have to worry about + // PNP/Power synchronization. + // A default queue gets all the requests that are not + // configure-fowarded using WdfDeviceConfigureRequestDispatching. + // + WDF_IO_QUEUE_CONFIG_INIT_DEFAULT_QUEUE( + &ioQueueConfig, + WdfIoQueueDispatchParallel + ); + + ioQueueConfig.EvtIoDeviceControl = t1394_EvtIoDeviceControl; + + status = WdfIoQueueCreate( + deviceExtension->WdfDevice, + &ioQueueConfig, + WDF_NO_OBJECT_ATTRIBUTES, + &deviceExtension->IoctlQueue // queue handle + ); + + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfIoQueueCreate failed 0x%x\n", status)); + return status; + } + + // + // Create an additional queue to hold bus reset requests. + // + WDF_IO_QUEUE_CONFIG_INIT( + &ioQueueConfig, + WdfIoQueueDispatchManual + ); + + status = WdfIoQueueCreate ( + deviceExtension->WdfDevice, + &ioQueueConfig, + WDF_NO_OBJECT_ATTRIBUTES, + &deviceExtension->BusResetRequestsQueue + ); + + if(!NT_SUCCESS (status)){ + //TRACE(TL_ERROR, ("Error Creating Reset Request Queue 0x%x\n", + // status)); + return status; + } + + // + // Create another IoTarget representing PortDeviceObject so that + // we can send async requests in rawmode directly to the port device. + // + WDF_IO_TARGET_OPEN_PARAMS_INIT_EXISTING_DEVICE(&openParams, + pNodeExt->PortDeviceObject); + status = WdfIoTargetCreate(device, + WDF_NO_OBJECT_ATTRIBUTES, + &deviceExtension->PortDeviceIoTarget); + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfIoTargetCreate failed 0x%x\n", status)); + return status; + } + + status = WdfIoTargetOpen(deviceExtension->PortDeviceIoTarget, &openParams); + if (!NT_SUCCESS (status)) { + //TRACE(TL_ERROR, ("WdfIoTargetCreate failed 0x%x\n", status)); + return status; + } + + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + // initialize the spinlock/list to store the bus reset irps... + + status = WdfSpinLockCreate(&lockAttributes,&deviceExtension->CromSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate CromSpinLock " + // "failed 0x%x\n", status)); + return status; + } + + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + + status = WdfSpinLockCreate(&lockAttributes, + &deviceExtension->AsyncSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate AsyncSpinLock " + // "failed 0x%x\n", status)); + return status; + } + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + + status = WdfSpinLockCreate(&lockAttributes, + &deviceExtension->IsochSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate IsochSpinLock " + // "failed 0x%x\n", status)); + return status; + } + + WDF_OBJECT_ATTRIBUTES_INIT(&lockAttributes); + lockAttributes.ParentObject = device; + + status = WdfSpinLockCreate(&lockAttributes, + &deviceExtension->IsochResourceSpinLock ); + if(!NT_SUCCESS(status)){ + //TRACE(TL_ERROR, ("WdfSpinLockCreate IsochResourceSpinLock " + // "failed 0x%x\n", status)); + return status; + } + InitializeListHead(&deviceExtension->CromData); + InitializeListHead(&deviceExtension->AsyncAddressData); + InitializeListHead(&deviceExtension->IsochDetachData); + InitializeListHead(&deviceExtension->IsochResourceData); + + //EXIT("t1394_PnpAddDevice", status); + + return(status); +} // t1394_PnpAddDevice + + +/****************************************************************************** + + DriverEntry + + ******************************************************************************/ + +NTSTATUS +DriverEntry( + /*IN*/PDRIVER_OBJECT DriverObject, + /*IN*/PUNICODE_STRING RegistryPath + ) +/*++ + +Routine Description: + + Installable driver initialization entry point. + This entry point is called directly by the I/O system. + +Arguments: + + DriverObject - pointer to the driver object + + RegistryPath - pointer to a unicode string representing the path, + to driver-specific key in the registry. + +Return Value: + + STATUS_SUCCESS if successful, + STATUS_UNSUCCESSFUL otherwise. + +--*/ +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + WDF_DRIVER_CONFIG config; + + //ENTER("DriverEntry"); + + // //TRACE(TL_TRACE, ("1394VDev Sample - Driver Framework Edition \n")); + // TRACE(TL_TRACE, ("Built %s %s\n", __DATE__, __TIME__)); + + // + // Initialize the Driver Config structure.. + // + WDF_DRIVER_CONFIG_INIT( + &config, + t1394_EvtDeviceAdd + ); + + // + // Create a WDFDRIVER object. + // + ntStatus = WdfDriverCreate( + DriverObject, + RegistryPath, + WDF_NO_OBJECT_ATTRIBUTES, + &config, + WDF_NO_HANDLE + ); + + if (!NT_SUCCESS(ntStatus)) { + // TRACE(TL_ERROR, ("WdfDriverCreate failed with status %x\n", ntStatus)); + } + + //EXIT("DriverEntry", ntStatus); + return(ntStatus); +} // DriverEntry + + + + + + + + +/****************************************************************************** + + main + + ******************************************************************************/ + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +void main() +{ + // This is the OS Model + NTSTATUS status; + PDRIVER_OBJECT DriverObject; + WDFDEVICE Device; + PWDFDEVICE_INIT DeviceInit; + WDFQUEUE Queue; + WDFREQUEST Request; + ULONG IoControlCode; + int InputBufferLength, OutputBufferLength; // symbolic + PUNICODE_STRING RegistryPath; // symbolic, genuinely don't care. + + // $Super$$main + status = SLAyer_harness_init() ; + + if (NT_SUCCESS(status)) { + // OSModel: call DriverEntry + DriverEntry(DriverObject,RegistryPath); + + // OSModel: Add N devices, for N=1. + t1394_EvtDeviceAdd(SL_Driver, DeviceInit); + + // OSModel: Make a queue. + Queue = (WDFQUEUE)malloc(sizeof(SLAyer_WDFOBJECT)); + Queue->typ = SLAyerWdfQueue; + Queue->typQueue.Device = SL_Device_one; + + // OSModel: Make a request. + Request = (WDFREQUEST)malloc(sizeof(SLAyer_WDFOBJECT)); + Request->typ = SLAyerWdfRequest; + Request->typRequest.InputBuffer = (void*)_SLAyer_malloc(1024); + + // OSModel: send request to 1393 Device, + // which can only do Request IOCTL_SET_LOCAL_HOST_INFORMATION. + t1394_EvtIoDeviceControl(Queue, Request, OutputBufferLength, InputBufferLength, IoControlCode); + + // SI: finish EvtIoDeviceControl first. + // t1394_EvtDeviceSelfManagedIoCleanup(Device); + + SLAyer_harness_teardown(); + } + +} + diff --git a/test/kmdf/1394/address_range_plist_entry.c b/test/kmdf/1394/address_range_plist_entry.c new file mode 100644 index 0000000..b4042b1 --- /dev/null +++ b/test/kmdf/1394/address_range_plist_entry.c @@ -0,0 +1,176 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: allocate_address_range_insert_head_list, + free_address_range_{remove_entry,insert_head}_list. + Source: asyncapi.c, lines 199, 278, 304. + Expected Result: SAFE, MAY LEAK. +*****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +NTSTATUS +t1394_FreeAddressRange( + PDEVICE_EXTENSION deviceExtension, + HANDLE hAddressRange + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + PASYNC_ADDRESS_DATA AsyncAddressData = NULL; + PLIST_ENTRY listHead; + PLIST_ENTRY thisEntry; + + // have to find our struct... + listHead = &deviceExtension->AsyncAddressData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + AsyncAddressData = NULL, thisEntry = thisEntry->Flink) + { + AsyncAddressData = CONTAINING_RECORD(thisEntry, ASYNC_ADDRESS_DATA, + AsyncAddressList); + + if (AsyncAddressData->hAddressRange == hAddressRange) { + RemoveEntryList(&AsyncAddressData->AsyncAddressList); + break; + } + } + + // never found an entry... + if (!AsyncAddressData) { + ntStatus = STATUS_INVALID_PARAMETER; + goto Exit_FreeAddressRange; + } + + // got it, lets free it... + // need to free up everything associated with this allocate... + if (AsyncAddressData->pMdl) { + IoFreeMdl(AsyncAddressData->pMdl); + } + if (AsyncAddressData->Buffer) { + ExFreePool(AsyncAddressData->Buffer); + } + + if (AsyncAddressData->AddressRange) { + ExFreePool(AsyncAddressData->AddressRange); + } + + if (AsyncAddressData) { + ExFreePool(AsyncAddressData); + } + + Exit_FreeAddressRange: + return(ntStatus); +} // t1394_FreeAddressRange + + + + +/****************************************************************************** + + main + + ******************************************************************************/ +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +NTSTATUS +main() +{ + PDEVICE_EXTENSION deviceExtension;// = &SL_Context; + PLIST_ENTRY listEntry; + PADDRESS_RANGE hAddressRange; + NTSTATUS ntStatus; + ULONG nLength; + unsigned int i, count; + + // OS Model init + ntStatus = SLAyer_harness_init(); + + // We set up dE->AAL to a steady state. + if (NT_SUCCESS(ntStatus)) { + // Setup. + deviceExtension = GetDeviceContext(SL_Device_one); + InitializeListHead(&(deviceExtension->AsyncAddressData)); + + for ( i=0; iBuffer = _SLAyer_malloc(nLength); + + pAsyncAddressData->AddressRange = _SLAyer_malloc(sizeof(ADDRESS_RANGE)); + + pAsyncAddressData->pMdl = + IoAllocateMdl(pAsyncAddressData->Buffer, + nLength, + FALSE, + FALSE, + NULL); + + InitializeListHead(&(pAsyncAddressData->AsyncAddressList)); + + InsertHeadList(&deviceExtension->AsyncAddressData, + &pAsyncAddressData->AsyncAddressList); + } + + + // 2. Delete some AsyncAddressDatas. + ntStatus = t1394_FreeAddressRange(deviceExtension, (HANDLE) hAddressRange); + + /* + */ + // Note: We currently LEAK; should teardown here. + /* + while (!IsListEmpty(&deviceExtension->AsyncAddressData)) { + + PASYNC_ADDRESS_DATA AsyncAddressData; + + // get struct off list + listEntry = RemoveHeadList(&deviceExtension->AsyncAddressData); + + AsyncAddressData = CONTAINING_RECORD(listEntry, ASYNC_ADDRESS_DATA, + AsyncAddressList); + + // need to free up everything associated with this allocate... + if (AsyncAddressData->pMdl) + IoFreeMdl(AsyncAddressData->pMdl); + + if (AsyncAddressData->Buffer) + ExFreePool(AsyncAddressData->Buffer); + + if (AsyncAddressData->AddressRange) + ExFreePool(AsyncAddressData->AddressRange); + + if (AsyncAddressData) + ExFreePool(AsyncAddressData); + } + */ + + SLAyer_harness_teardown(); + } + + return ntStatus; +} + + diff --git a/test/kmdf/1394/allocate_resources_insert_head_list.c b/test/kmdf/1394/allocate_resources_insert_head_list.c new file mode 100644 index 0000000..6d099ca --- /dev/null +++ b/test/kmdf/1394/allocate_resources_insert_head_list.c @@ -0,0 +1,45 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: allocate_resources_insert_head_list. + Source: isochapi.c, line 223. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +NTSTATUS +t1394_IsochAllocateResources(PDEVICE_EXTENSION deviceExtension) +{ + PISOCH_RESOURCE_DATA IsochResourceData; + + // need to add to our list... + IsochResourceData = (PISOCH_RESOURCE_DATA)malloc(sizeof(ISOCH_RESOURCE_DATA)); + + { + InsertHeadList(&deviceExtension->IsochResourceData, + &IsochResourceData->IsochResourceList); + } + return STATUS_SUCCESS; + +} // t1394_IsochAllocateResources + + +int main () +{ + PDEVICE_EXTENSION deviceExtension; + NTSTATUS ntStatus = STATUS_SUCCESS; + PLIST_ENTRY prd ; + + // 0. Initialize devExt. + deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(DEVICE_EXTENSION)); + InitializeListHead(&(deviceExtension->IsochResourceData)); + + ntStatus = t1394_IsochAllocateResources(deviceExtension); + ntStatus = t1394_IsochAllocateResources(deviceExtension); + ntStatus = t1394_IsochAllocateResources(deviceExtension); + ntStatus = t1394_IsochAllocateResources(deviceExtension); + + return ntStatus; +} + diff --git a/test/kmdf/1394/attach_buffer_insert_head_list.c b/test/kmdf/1394/attach_buffer_insert_head_list.c new file mode 100644 index 0000000..601b16d --- /dev/null +++ b/test/kmdf/1394/attach_buffer_insert_head_list.c @@ -0,0 +1,79 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: attach_buffer_insert_head_list. + Source: isochapi.c, line 432. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +NTSTATUS +t1394_IsochAttachBuffers(PDEVICE_EXTENSION deviceExtension) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + PISOCH_DETACH_DATA pIsochDetachData = NULL; + + pIsochDetachData = (PISOCH_DETACH_DATA)malloc(sizeof(ISOCH_DETACH_DATA)); + if (!pIsochDetachData) + { + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_IsochAttachBuffers; + } + pIsochDetachData->DeviceExtension = deviceExtension; + InitializeListHead(&pIsochDetachData->IsochDetachList); + InsertHeadList(&deviceExtension->IsochDetachData, + &pIsochDetachData->IsochDetachList); + + Exit_IsochAttachBuffers: + return(ntStatus); +} // t1394_IsochAttachBuffers + + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + PDEVICE_EXTENSION deviceExtension; + NTSTATUS ntStatus; + + // OS Model init + ntStatus = SLAyer_harness_init(); + + if (NT_SUCCESS(ntStatus)) { + deviceExtension = GetDeviceContext(SL_Device_one); + + // Setup + InitializeListHead(&(deviceExtension->IsochDetachData)); + + while (nondet()) { + ntStatus = t1394_IsochAttachBuffers(deviceExtension); + } + + // OS Model Teardown. + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(ntStatus)); + +} diff --git a/test/kmdf/1394/attach_completion_routine_remove_entry_list.c b/test/kmdf/1394/attach_completion_routine_remove_entry_list.c new file mode 100644 index 0000000..fb75b53 --- /dev/null +++ b/test/kmdf/1394/attach_completion_routine_remove_entry_list.c @@ -0,0 +1,199 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: attach_completion_routine_remove_entry_list. + Expected Result: SAFE, MAY LEAK. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +/* Source: WDK/src_5239/kmdf/1394/util.c, line 60. */ +BOOLEAN +t1394_IsOnList( + PLIST_ENTRY Entry, + PLIST_ENTRY List + ) +{ + PLIST_ENTRY TempEntry; + + for( + TempEntry = List->Flink; + TempEntry != List; + TempEntry = TempEntry->Flink + ) + { + if (TempEntry == Entry) + { +/* TRACE(TL_TRACE, ("Entry 0x%x found on list 0x%x\n", Entry, List)); */ + return TRUE; + } + } + +/* TRACE(TL_TRACE, ("Entry 0x%x not found on list 0x%x\n", Entry, List)); */ + return FALSE; +} + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 1416. */ +NTSTATUS +t1394_IsochAttachCompletionRoutine( + PDEVICE_EXTENSION DeviceExtension, /* added for SLAyer */ +/* IN PDEVICE_OBJECT Device, */ +/* IN PIRP Irp, */ + /* IN */ PISOCH_DETACH_DATA IsochDetachData + ) +{ +/* PDEVICE_EXTENSION DeviceExtension; */ + NTSTATUS ntStatus = STATUS_SUCCESS; + ULONG i; + +/* UNREFERENCED_PARAMETER(Device); */ +/* UNREFERENCED_PARAMETER(Irp); */ + +/* ENTER("t1394_IsochAttachCompletionRoutine"); */ + + if (!IsochDetachData) + { +/* TRACE(TL_WARNING, ("IsochAttachCompletionRoutine: IsochDetachData = 0x%x\n", */ +/* IsochDetachData)); */ +/* IoFreeIrp (Irp); */ + goto Exit_IsochAttachCompletionRoutine; + } + +/* if (!NT_SUCCESS(Irp->IoStatus.Status)) */ + { + // make sure this irp is still on the device extension list, meaning no one else + // has already handled this yet +/* DeviceExtension = IsochDetachData->DeviceExtension; */ + + WdfSpinLockAcquire(DeviceExtension->IsochSpinLock); + if (t1394_IsOnList(&IsochDetachData->IsochDetachList, &DeviceExtension->IsochDetachData)) + { + RemoveEntryList(&IsochDetachData->IsochDetachList); +/* KeCancelTimer(&IsochDetachData->Timer); */ + + WdfSpinLockRelease(DeviceExtension->IsochSpinLock); + } + else + { + // just bomb out here + + WdfSpinLockRelease(DeviceExtension->IsochSpinLock); + goto Exit_IsochAttachCompletionRoutine; + } +/* TRACE(TL_ERROR, ("Isoch Attach Failed! = 0x%x\n", Irp->IoStatus.Status)); */ +/* ntStatus = Irp->IoStatus.Status; */ + + if (!IsochDetachData) + { + goto Exit_IsochAttachCompletionRoutine; + } + +/* DeviceExtension = IsochDetachData->DeviceExtension; */ + +/* TRACE(TL_TRACE, ("IsochAttachCompletionRoutine: IsochDetachData = 0x%x\n", IsochDetachData)); */ +/* TRACE(TL_TRACE, ("IsochAttachCompletionRoutine: IsochDetachData->Request = 0x%x\n", IsochDetachData->Request)); */ +/* TRACE(TL_TRACE, ("IsochAttachCompletionRoutine: IsochDetachData->newIrp = 0x%x\n", IsochDetachData->newIrp)); */ +/* TRACE(TL_TRACE, ("Now lets complete Irp.\n")); */ + +/* if (IsochDetachData->AttachIrb) */ +/* { */ +/* ExFreePool(IsochDetachData->AttachIrb); */ +/* } */ + +/* for (i=0; inumIsochDescriptors; i++) */ +/* { */ +/* if (IsochDetachData->IsochDescriptor[i].Mdl) */ +/* { */ +/* IoFreeMdl(IsochDetachData->IsochDescriptor[i].Mdl); */ +/* } */ +/* } */ + +/* ExFreePool(IsochDetachData->IsochDescriptor); */ + + // + // Complete original Irp and free the one we allocated in + // IsochAttachBuffers + // + //IsochDetachData->Irp->IoStatus = Irp->IoStatus; +/* WdfRequestCompleteWithInformation(IsochDetachData->Request, Irp->IoStatus.Status, 0); */ +/* IoFreeIrp (IsochDetachData->newIrp); */ + + // all done with IsochDetachData, lets deallocate it... + ExFreePool(IsochDetachData); + } + +Exit_IsochAttachCompletionRoutine: + +/* EXIT("t1394_IsochAttachCompletionRoutine", ntStatus); */ + return(STATUS_MORE_PROCESSING_REQUIRED); +} // t1394_IsochAttachCompletionRoutine + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + NTSTATUS ntStatus; + PDEVICE_EXTENSION deviceExtension; + PISOCH_DETACH_DATA obj_to_del = NULL; + int choice; + unsigned int count, i; + PISOCH_DETACH_DATA pidd; + + // OS Model init + ntStatus = SLAyer_harness_init(); + + if (NT_SUCCESS(ntStatus)) { + deviceExtension = GetDeviceContext(SL_Device_one); + + // Setup + InitializeListHead(&(deviceExtension->IsochDetachData)); + + // Add some IsochDetachData off deviceExtension. + // Set obj_to_del to one of these. + for (i=0; iDeviceExtension = deviceExtension; + InsertHeadList(&(deviceExtension->IsochDetachData),&(pidd->IsochDetachList)); + } + if (!obj_to_del) obj_to_del = pidd; + + // assert: obj_to_del should now point to one of devicExtension->IsochResourceData. + ntStatus = t1394_IsochAttachCompletionRoutine(deviceExtension, obj_to_del); + // assert: devExt.IsochDetachData > devExt.IsochDeatchData' + + // Now set obj_to_del to something new. + obj_to_del = (PISOCH_DETACH_DATA)malloc(sizeof(ISOCH_DETACH_DATA)); + obj_to_del->DeviceExtension = deviceExtension; + InitializeListHead(&(obj_to_del->IsochDetachList)); + + t1394_IsochAttachCompletionRoutine(deviceExtension, obj_to_del); + // assert: devExt = devExt' + + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(ntStatus)); + +} diff --git a/test/kmdf/1394/callback_remove_entry_list.c b/test/kmdf/1394/callback_remove_entry_list.c new file mode 100644 index 0000000..09a49b8 --- /dev/null +++ b/test/kmdf/1394/callback_remove_entry_list.c @@ -0,0 +1,261 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: callback_remove_entry_list. + Expected Result: SAFE, MAY LEAK. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +/* Source: WDK/src_5239/kmdf/1394/util.c, line 60. */ +BOOLEAN +t1394_IsOnList( + PLIST_ENTRY Entry, + PLIST_ENTRY List + ) +{ + PLIST_ENTRY TempEntry; + + for( + TempEntry = List->Flink; + TempEntry != List; + TempEntry = TempEntry->Flink + ) + { + if (TempEntry == Entry) + { +/* TRACE(TL_TRACE, ("Entry 0x%x found on list 0x%x\n", Entry, List)); */ + return TRUE; + } + } + +/* TRACE(TL_TRACE, ("Entry 0x%x not found on list 0x%x\n", Entry, List)); */ + return FALSE; +} + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 1238. */ +void +t1394_IsochCleanup( + /* IN */ PISOCH_DETACH_DATA IsochDetachData + ) +{ + ULONG i; + PDEVICE_EXTENSION DeviceExtension; + +/* ENTER("t1394_IsochCleanup"); */ + +/* DeviceExtension = IsochDetachData->DeviceExtension; */ + + // + // see if we need to detach this buffer + // + if ((!IsochDetachData) || (!DeviceExtension)) + { + goto Exit_IsochDetachBuffers; + } + +/* if (IsochDetachData->bDetach) */ { + + PIRB pIrb; + NTSTATUS ntStatus; +/* PIO_STACK_LOCATION NextIrpStack; */ + + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + + if (!pIrb) { + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ +/* TRACE(TL_WARNING, ("Can't detach buffer!\n")); */ + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_IsochDetachBuffers; + } // if + + // save the irb in our detach data context +/* IsochDetachData->DetachIrb = pIrb; */ + + RtlZeroMemory (pIrb, sizeof (IRB)); +/* pIrb->FunctionNumber = REQUEST_ISOCH_DETACH_BUFFERS; */ + pIrb->Flags = 0; +/* pIrb->u.IsochDetachBuffers.hResource = IsochDetachData->hResource; */ +/* pIrb->u.IsochDetachBuffers.nNumberOfDescriptors = IsochDetachData->numIsochDescriptors; */ +/* pIrb->u.IsochDetachBuffers.pIsochDescriptor = IsochDetachData->IsochDescriptor; */ + +/* NextIrpStack = IoGetNextIrpStackLocation(IsochDetachData->newIrp); */ +/* NextIrpStack->MajorFunction = IRP_MJ_INTERNAL_DEVICE_CONTROL; */ +/* NextIrpStack->Parameters.DeviceIoControl.IoControlCode = IOCTL_1394_CLASS; */ +/* NextIrpStack->Parameters.Others.Argument1 = pIrb; */ + +/* IoSetCompletionRoutine( IsochDetachData->newIrp, */ +/* t1394_IsochDetachCompletionRoutine, */ +/* IsochDetachData, */ +/* TRUE, */ +/* TRUE, */ +/* TRUE */ +/* ); */ + +/* IoCallDriver(DeviceExtension->StackDeviceObject, IsochDetachData->newIrp); */ + } +/* else */ { + +/* TRACE(TL_TRACE, ("Complete Irp.\n")); */ + +/* if (IsochDetachData->AttachIrb) */ +/* { */ +/* ExFreePool(IsochDetachData->AttachIrb); */ +/* } */ + +/* for (i=0; inumIsochDescriptors; i++) */ +/* { */ +/* if (IsochDetachData->IsochDescriptor[i].Mdl) */ +/* { */ +/* IoFreeMdl(IsochDetachData->IsochDescriptor[i].Mdl); */ +/* } */ +/* } */ + +/* ExFreePool(IsochDetachData->IsochDescriptor); */ + + //IsochDetachData->Irp->IoStatus.Status = IsochDetachData->AttachStatus; + + // only set this if its a success... +/* if (NT_SUCCESS(IsochDetachData->AttachStatus)) */ + { + //IsochDetachData->Irp->IoStatus.Information = IsochDetachData->outputBufferLength; + } + + // + // Complete original Irp and free the one we allocated in + // IsochAttachBuffers + // +/* WdfRequestCompleteWithInformation(IsochDetachData->Request, */ +/* IsochDetachData->AttachStatus, */ +/* IsochDetachData->outputBufferLength); */ +/* IoFreeIrp (IsochDetachData->newIrp); */ + + // all done with IsochDetachData, lets deallocate it... + ExFreePool(IsochDetachData); + } + +Exit_IsochDetachBuffers: + +/* EXIT("t1394_IsochCleanup", 0) */; +} // t1394_IsochCleanup + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 1132. */ +void +t1394_IsochCallback( + /* IN */ PDEVICE_EXTENSION DeviceExtension, + /* IN */ PISOCH_DETACH_DATA IsochDetachData + ) +{ +/* ENTER("t1394_IsochCallback"); */ + + if (!IsochDetachData) + { + goto Exit_IsochCallback; + } + + // make sure somebody else isn't already handling cleaning up for this request + + WdfSpinLockAcquire(DeviceExtension->IsochSpinLock); + if (t1394_IsOnList(&IsochDetachData->IsochDetachList, &DeviceExtension->IsochDetachData)) + { + + RemoveEntryList(&IsochDetachData->IsochDetachList); + + WdfSpinLockRelease(DeviceExtension->IsochSpinLock); +/* KeCancelTimer(&IsochDetachData->Timer); */ + +/* TRACE(TL_TRACE, ("IsochCallback: IsochDetachData = 0x%x\n", IsochDetachData)); */ +/* TRACE(TL_TRACE, ("IsochCallback: IsochDetachData->Request = 0x%x\n", IsochDetachData->Request)); */ +/* TRACE(TL_TRACE, ("IsochCallback: IsochDetachData->newIrp = 0x%x\n", IsochDetachData->newIrp)); */ + + // need to save the status of the attach + // we'll clean up in the same spot for success's and timeout's + // Note: IsochDetachData->AttachStatus = IsochDetachData->Irp->IoStatus.Status; + t1394_IsochCleanup(IsochDetachData); + } + else + { +/* TRACE(TL_TRACE, ("IsochCallback: Entry 0x%x not on List 0x%x\n", */ +/* IsochDetachData->IsochDetachList, DeviceExtension->IsochDetachData)); */ + + WdfSpinLockRelease(DeviceExtension->IsochSpinLock); + + } + +Exit_IsochCallback: +/* EXIT("t1394_IsochCallback", 0) */; +} // t1394_IsochCallback + + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + PDEVICE_EXTENSION deviceExtension; + NTSTATUS ntStatus; + PISOCH_DETACH_DATA pidd; + PISOCH_DETACH_DATA obj_to_del = NULL; + int choice; + unsigned int count, i; + + + // OS Model init + ntStatus = SLAyer_harness_init(); + + if (NT_SUCCESS(ntStatus)) { + deviceExtension = GetDeviceContext(SL_Device_one); + + // Setup + InitializeListHead(&(deviceExtension->IsochDetachData)); + + // Add some IsochDetachData off deviceExtension. + // Set obj_to_del to one of these. + for (i=0; iDeviceExtension = deviceExtension; + InsertHeadList(&(deviceExtension->IsochDetachData), + &(pidd->IsochDetachList)); + } + if (!obj_to_del) obj_to_del = pidd; + + t1394_IsochCallback(deviceExtension, obj_to_del); + + // Now set obj_to_del to something new. + obj_to_del = (PISOCH_DETACH_DATA)malloc(sizeof(ISOCH_DETACH_DATA)); + obj_to_del->DeviceExtension = deviceExtension; + InitializeListHead(&(obj_to_del->IsochDetachList)); + + t1394_IsochCallback(deviceExtension, obj_to_del); + // assert: devExt = devExt' + + // OS Model teardown + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(ntStatus)); + +} diff --git a/test/kmdf/1394/cleanup_asyncaddressdata_remove_head_list.c b/test/kmdf/1394/cleanup_asyncaddressdata_remove_head_list.c new file mode 100644 index 0000000..0cd0783 --- /dev/null +++ b/test/kmdf/1394/cleanup_asyncaddressdata_remove_head_list.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: cleanup_asyncaddressdata_remove_head_list. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +/* Source: WDK/src_5239/kmdf/1394/pnp.c, line 561. */ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( +/* IN WDFDEVICE Device */ + PDEVICE_EXTENSION deviceExtension /* added for SLAyer */ + ) +{ + PLIST_ENTRY listEntry; + + // lets free up any allocated addresses and deallocate all + // memory associated with them... + + WdfSpinLockAcquire(deviceExtension->AsyncSpinLock); + + while (!IsListEmpty(&deviceExtension->AsyncAddressData)) { + + PASYNC_ADDRESS_DATA AsyncAddressData; + + // get struct off list + listEntry = RemoveHeadList(&deviceExtension->AsyncAddressData); + + AsyncAddressData = CONTAINING_RECORD(listEntry, ASYNC_ADDRESS_DATA, + AsyncAddressList); + + // need to free up everything associated with this allocate... + if (AsyncAddressData->pMdl) + IoFreeMdl(AsyncAddressData->pMdl); + + if (AsyncAddressData->Buffer) + ExFreePool(AsyncAddressData->Buffer); + + if (AsyncAddressData->AddressRange) + ExFreePool(AsyncAddressData->AddressRange); + + if (AsyncAddressData) + ExFreePool(AsyncAddressData); + } + + + WdfSpinLockRelease(deviceExtension->AsyncSpinLock); + +} + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + + +int main() +{ + NTSTATUS status; + PDEVICE_EXTENSION devExt ; + unsigned int count, i; + + status = SLAyer_harness_init(); + + if (NT_SUCCESS(status)) { + devExt = GetDeviceContext(SL_Device_one); + + InitializeListHead(&(devExt->AsyncAddressData)); + + for (i=0; ipMdl = (PMDL)malloc(sizeof(MDL)); + + pdata->Buffer = malloc(1); + + pdata->AddressRange = (PADDRESS_RANGE)malloc(sizeof(ADDRESS_RANGE)); + + InsertHeadList(&(devExt->AsyncAddressData), &(pdata->AsyncAddressList)); + } + + // 2. Delete all AsyncAddressDatas. + t1394_EvtDeviceSelfManagedIoCleanup(devExt); + + // OS Model teardown + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(status)); +} + + diff --git a/test/kmdf/1394/cleanup_cromdata_remove_head_list.c b/test/kmdf/1394/cleanup_cromdata_remove_head_list.c new file mode 100644 index 0000000..bdd9a09 --- /dev/null +++ b/test/kmdf/1394/cleanup_cromdata_remove_head_list.c @@ -0,0 +1,105 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: cleanup_cromdata_remove_head_list. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + +/* Source: WDK/src_5239/kmdf/1394/pnp.c, line 531. */ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( +/* IN WDFDEVICE Device */ + PDEVICE_EXTENSION deviceExtension /* added for SLAyer */ + ) +{ + PLIST_ENTRY listEntry; + + // lets free up any crom data structs we've allocated... + + WdfSpinLockAcquire(deviceExtension->CromSpinLock); + + while (!IsListEmpty(&deviceExtension->CromData)) { + + PCROM_DATA CromData; + + // get struct off list + + listEntry = RemoveHeadList(&deviceExtension->CromData); + CromData = CONTAINING_RECORD(listEntry, CROM_DATA, CromList); + + // need to free up everything associated with this allocate... + if (CromData) + { + if (CromData->Buffer) + ExFreePool(CromData->Buffer); + + if (CromData->pMdl) + IoFreeMdl(CromData->pMdl); + + // we already checked CromData + ExFreePool(CromData); + } + } + + + WdfSpinLockRelease(deviceExtension->CromSpinLock); + +} + + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +NTSTATUS +main() +{ + NTSTATUS status; + PDEVICE_EXTENSION devExt; + unsigned int count, i; // count=* + + // OS Model init + status = SLAyer_harness_init(); + + if (NT_SUCCESS(status)) { + + devExt = GetDeviceContext(SL_Device_one); + + InitializeListHead(&(devExt->CromData)); + + for (i=0; iBuffer = (PVOID)malloc(sizeof(int)); + CromData->pMdl = (PMDL)malloc(sizeof(MDL)); + InsertHeadList(&(devExt->CromData),&(CromData->CromList)); + } + + // 2. Delete all CromDatas. + t1394_EvtDeviceSelfManagedIoCleanup(devExt); + + // OS Model teardown + SLAyer_harness_teardown(); + } + + return STATUS_SUCCESS; +} diff --git a/test/kmdf/1394/cleanup_isochdetachdata_remove_head_list.c b/test/kmdf/1394/cleanup_isochdetachdata_remove_head_list.c new file mode 100644 index 0000000..46bfb76 --- /dev/null +++ b/test/kmdf/1394/cleanup_isochdetachdata_remove_head_list.c @@ -0,0 +1,305 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: cleanup_isochdetachdata_remove_head_list. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" +#include "common.h" + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 1344. */ +NTSTATUS +t1394_IsochDetachCompletionRoutine( + /* IN */ PDEVICE_OBJECT Device, + /* IN */ PIRP Irp, + /* IN */ PISOCH_DETACH_DATA IsochDetachData + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; + ULONG i; + +/* UNREFERENCED_PARAMETER(Device); */ +/* UNREFERENCED_PARAMETER(Irp); */ +/* UNREFERENCED_PARAMETER(ntStatus); */ + +/* ENTER("t1394_IsochDetachCompletionRoutine"); */ + + if (!IsochDetachData) { + +/* TRACE(TL_WARNING, ("Invalid IsochDetachData\n")); */ + goto Exit_IsochDetachCompletionRoutine; + } + +/* if (IsochDetachData->DetachIrb) */ +/* { */ +/* ExFreePool(IsochDetachData->DetachIrb); */ +/* } */ +/* TRACE(TL_TRACE, ("Now lets complete the Irp.\n")); */ + +/* if (IsochDetachData->AttachIrb) */ +/* ExFreePool(IsochDetachData->AttachIrb); */ + +/* for (i=0; inumIsochDescriptors; i++) */ +/* { */ + +/* if (IsochDetachData->IsochDescriptor[i].Mdl) */ +/* { */ +/* IoFreeMdl(IsochDetachData->IsochDescriptor[i].Mdl); */ +/* } */ +/* } */ + +/* if (IsochDetachData->IsochDescriptor) */ +/* { */ +/* ExFreePool(IsochDetachData->IsochDescriptor); */ +/* } */ + + // only set this if its a success... +/* if (NT_SUCCESS(IsochDetachData->AttachStatus)) */ +/* { */ +/* //IsochDetachData->Irp->IoStatus.Information = IsochDetachData->outputBufferLength; */ +/* } */ + + //IsochDetachData->Irp->IoStatus.Status = IsochDetachData->AttachStatus; + + // + // Complete original Irp and free the one we allocated in + // IsochAttachBuffers + // +/* WdfRequestCompleteWithInformation(IsochDetachData->Request, IsochDetachData->AttachStatus, IsochDetachData->outputBufferLength); */ +/* IoFreeIrp (IsochDetachData->newIrp); */ + + // all done with IsochDetachData, lets deallocate it... + if (IsochDetachData) + { + ExFreePool(IsochDetachData); + } + +Exit_IsochDetachCompletionRoutine: + +/* EXIT("t1394_IsochDetachCompletionRoutine", ntStatus); */ + return(STATUS_MORE_PROCESSING_REQUIRED); +} // t1394_IsochDetachCompletionRoutine + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 1238. */ +void +t1394_IsochCleanup( + /* IN */ PISOCH_DETACH_DATA IsochDetachData + ) +{ +/* ULONG i; */ +/* PDEVICE_EXTENSION DeviceExtension; */ + +/* ENTER("t1394_IsochCleanup"); */ + +/* DeviceExtension = IsochDetachData->DeviceExtension; */ + + // + // see if we need to detach this buffer + // + if ((!IsochDetachData) /* || (!DeviceExtension) */) + { + goto Exit_IsochDetachBuffers; + } + +/* if (IsochDetachData->bDetach) { */ + +/* PIRB pIrb; */ +/* NTSTATUS ntStatus; */ +/* PIO_STACK_LOCATION NextIrpStack; */ + +/* pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); */ + +/* if (!pIrb) { */ + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ +/* TRACE(TL_WARNING, ("Can't detach buffer!\n")); */ +/* ntStatus = STATUS_INSUFFICIENT_RESOURCES; */ +/* goto Exit_IsochDetachBuffers; */ +/* } // if */ + + // save the irb in our detach data context +/* IsochDetachData->DetachIrb = pIrb; */ + +/* RtlZeroMemory (pIrb, sizeof (IRB)); */ +/* pIrb->FunctionNumber = REQUEST_ISOCH_DETACH_BUFFERS; */ +/* pIrb->Flags = 0; */ +/* pIrb->u.IsochDetachBuffers.hResource = IsochDetachData->hResource; */ +/* pIrb->u.IsochDetachBuffers.nNumberOfDescriptors = IsochDetachData->numIsochDescriptors; */ +/* pIrb->u.IsochDetachBuffers.pIsochDescriptor = IsochDetachData->IsochDescriptor; */ + +/* NextIrpStack = IoGetNextIrpStackLocation(IsochDetachData->newIrp); */ +/* NextIrpStack->MajorFunction = IRP_MJ_INTERNAL_DEVICE_CONTROL; */ +/* NextIrpStack->Parameters.DeviceIoControl.IoControlCode = IOCTL_1394_CLASS; */ +/* NextIrpStack->Parameters.Others.Argument1 = pIrb; */ + +/* IoSetCompletionRoutine( IsochDetachData->newIrp, */ +/* t1394_IsochDetachCompletionRoutine, */ +/* IsochDetachData, */ +/* TRUE, */ +/* TRUE, */ +/* TRUE */ +/* ); */ + +/* IoCallDriver(DeviceExtension->StackDeviceObject, IsochDetachData->newIrp); */ +/* } */ +/* else { */ + +/* TRACE(TL_TRACE, ("Complete Irp.\n")); */ + +/* if (IsochDetachData->AttachIrb) */ +/* { */ +/* ExFreePool(IsochDetachData->AttachIrb); */ +/* } */ + +/* for (i=0; inumIsochDescriptors; i++) */ +/* { */ +/* if (IsochDetachData->IsochDescriptor[i].Mdl) */ +/* { */ +/* IoFreeMdl(IsochDetachData->IsochDescriptor[i].Mdl); */ +/* } */ +/* } */ + +/* ExFreePool(IsochDetachData->IsochDescriptor); */ + + //IsochDetachData->Irp->IoStatus.Status = IsochDetachData->AttachStatus; + + // only set this if its a success... +/* if (NT_SUCCESS(IsochDetachData->AttachStatus)) */ +/* { */ +/* //IsochDetachData->Irp->IoStatus.Information = IsochDetachData->outputBufferLength; */ +/* } */ + + // + // Complete original Irp and free the one we allocated in + // IsochAttachBuffers + // +/* WdfRequestCompleteWithInformation(IsochDetachData->Request, */ +/* IsochDetachData->AttachStatus, */ +/* IsochDetachData->outputBufferLength); */ +/* IoFreeIrp (IsochDetachData->newIrp); */ + + // all done with IsochDetachData, lets deallocate it... + ExFreePool(IsochDetachData); +/* } */ + +Exit_IsochDetachBuffers: + +/* EXIT("t1394_IsochCleanup", 0) */; +} // t1394_IsochCleanup + + +/* Source: WDK/src_5239/kmdf/1394/pnp.c, line 593. */ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( +/* IN WDFDEVICE Device */ + PDEVICE_EXTENSION deviceExtension /* added for SLAyer */ + ) +{ + PLIST_ENTRY listEntry; + + // + // Free up any attached isoch buffers + // Note: There are known bugs in this code path + // + WHILE (TRUE) { + + WdfSpinLockAcquire(deviceExtension->IsochSpinLock); + + if (!IsListEmpty(&deviceExtension->IsochDetachData)) { + + PISOCH_DETACH_DATA IsochDetachData; + +/* IsochDetachData = (PISOCH_DETACH_DATA) */ +/* RemoveHeadList(&deviceExtension->IsochDetachData); */ + +/* SLAyer: This cast assumes IsochDetachList is the first field, replaced by: */ + listEntry = RemoveHeadList(&deviceExtension->IsochDetachData); + + IsochDetachData = CONTAINING_RECORD ( + listEntry, + ISOCH_DETACH_DATA, + IsochDetachList); +/* SLAyer: end replace */ + +/* TRACE(TL_TRACE, ("Surprise Removal: IsochDetachData = 0x%x\n", */ +/* IsochDetachData)); */ + +/* KeCancelTimer(&IsochDetachData->Timer); */ + + WdfSpinLockRelease(deviceExtension->IsochSpinLock); + +/* TRACE(TL_TRACE, ("Surprise Removal: IsochDetachData->Irp = 0x%x\n", */ +/* IsochDetachData->Request)); */ + + // need to save the status of the attach + // we'll clean up in the same spot for success's and timeout's +/* IsochDetachData->AttachStatus = STATUS_SUCCESS; */ + + // detach no matter what... +/* IsochDetachData->bDetach = TRUE; */ + + t1394_IsochCleanup(IsochDetachData); + } + else { + + WdfSpinLockRelease(deviceExtension->IsochSpinLock); + break; + } + } + +} + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + NTSTATUS status; + PDEVICE_EXTENSION devExt ; + unsigned int count, i; + + // OS Model init + status = SLAyer_harness_init(); + + if (NT_SUCCESS(status)) { + devExt = GetDeviceContext(SL_Device_one); + + InitializeListHead(&(devExt->IsochDetachData)); + + for (i=0; iDeviceExtension = devExt; + InsertHeadList(&(devExt->IsochDetachData), &(pdata->IsochDetachList)); + } + + t1394_EvtDeviceSelfManagedIoCleanup(devExt); + + // OS Model teardown + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(status)); +} + diff --git a/test/kmdf/1394/cleanup_isochresourcedata_remove_head_list.c b/test/kmdf/1394/cleanup_isochresourcedata_remove_head_list.c new file mode 100644 index 0000000..9b449ac --- /dev/null +++ b/test/kmdf/1394/cleanup_isochresourcedata_remove_head_list.c @@ -0,0 +1,189 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: cleanup_isochresourcedata_remove_head_list. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" +#include "common.h" + +NTSTATUS +t1394_SubmitIrpSynch( + IN WDFIOTARGET IoTarget, + IN WDFREQUEST Request, + IN PIRB Irb + ) +{ + NTSTATUS ntStatus /* = STATUS_SUCCESS */; + +/* WDF_REQUEST_SEND_OPTIONS option; */ +/* WDF_MEMORY_DESCRIPTOR descriptor; */ + +/* UNREFERENCED_PARAMETER(Request); */ + +/* ENTER("t1394_SubmitIrpSynch"); */ + +/* ASSERT(KeGetCurrentIrql() < DISPATCH_LEVEL); */ +/* ASSERT(Irb); */ + +/* WDF_REQUEST_SEND_OPTIONS_INIT(&option, WDF_REQUEST_SEND_OPTION_SYNCHRONOUS); */ + +/* TRACE(TL_TRACE, ("t1394_SubmitIrpSynch: Irp is pending...\n")); */ + +/* WDF_MEMORY_DESCRIPTOR_INIT_BUFFER(&descriptor, Irb, sizeof (IRB)); */ + +/* ntStatus = WdfIoTargetSendInternalIoctlOthersSynchronously(IoTarget, NULL, IOCTL_1394_CLASS, &descriptor, NULL, NULL, &option, NULL); */ +/* if (!NT_SUCCESS(ntStatus)) { */ +/* TRACE(TL_ERROR, ("WdfIoTargetSendInternalIoctlSynchronouslyOthers Failed with status %x\n",ntStatus)); */ +/* } */ + +/* EXIT("t1394_SubmitIrpSynch", ntStatus); */ + return(ntStatus); +} // t1394_SubmitIrpSynch + +/* Source: WDK/src_5239/kmdf/1394/pnp.c, line 634. */ +VOID +t1394_EvtDeviceSelfManagedIoCleanup( +/* IN WDFDEVICE Device */ + PDEVICE_EXTENSION deviceExtension /* added for SLAyer */ + ) +{ + PLIST_ENTRY listEntry; + + // + // Remove any isoch resource data + // + WHILE (TRUE) { + + WdfSpinLockAcquire(deviceExtension->IsochResourceSpinLock); + + if (!IsListEmpty(&deviceExtension->IsochResourceData)) { + + PISOCH_RESOURCE_DATA IsochResourceData = NULL; + +/* listEntry = RemoveHeadList(&deviceExtension->CromData); */ +/* SLAyer: above seems buggy, replaced by below */ + listEntry = RemoveHeadList(&deviceExtension->IsochResourceData); + + IsochResourceData = CONTAINING_RECORD(listEntry, + ISOCH_RESOURCE_DATA, + IsochResourceList); + + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + +/* TRACE(TL_TRACE, ("Surprise Removal: IsochResourceData = 0x%x\n", */ +/* IsochResourceData)); */ + + if (IsochResourceData) { + + PIRB pIrb; + WDFREQUEST request; + NTSTATUS status; + +/* TRACE(TL_TRACE, ("Surprise Removal: Freeing hResource = 0x%x\n", */ +/* IsochResourceData->hResource)); */ + + status = WdfRequestCreate( + WDF_NO_OBJECT_ATTRIBUTES, + deviceExtension->StackIoTarget, + &request); + + if (!NT_SUCCESS(status)) { +/* TRACE(TL_ERROR, ("Failed to allocate request %x\n", status)); */ + free(IsochResourceData); /* SLAyer: added */ + } + else { + + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + + if (!pIrb) { + + WdfObjectDelete(request); + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ + free(IsochResourceData); /* SLAyer: added */ + } + else { + + RtlZeroMemory (pIrb, sizeof (IRB)); + pIrb->FunctionNumber = REQUEST_ISOCH_FREE_RESOURCES; + pIrb->Flags = 0; + pIrb->u.IsochFreeResources.hResource = IsochResourceData->hResource; + + status = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, request, pIrb); + free(IsochResourceData); /* SLAyer: added */ + + if (!NT_SUCCESS(status)) { + +/* TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", status)); */ + } + + ExFreePool(pIrb); + WdfObjectDelete(request); + } + } + } + } + else { + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + break; + } + } + +/* EXIT("t1394_PnpRemoveDevice", STATUS_SUCCESS); */ + +} + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + if (NULL != SL_Device_one->Context) { free(SL_Device_one->Context); } + free(SL_Device_one); +} + +NTSTATUS +main() +{ + NTSTATUS status; + PDEVICE_EXTENSION devExt; + unsigned int count, i; + + status = SLAyer_harness_init(); + + if (NT_SUCCESS(status)) { + devExt = GetDeviceContext(SL_Device_one); + + InitializeListHead(&(devExt->IsochResourceData)); + + for (i=0; iIsochResourceData),&(pdata->IsochResourceList)); + } + + // 2. Delete all Isochresourcedatas. + t1394_EvtDeviceSelfManagedIoCleanup(devExt); + + SLAyer_harness_teardown(); + } + + + + return STATUS_SUCCESS; +} + + diff --git a/test/kmdf/1394/common.h b/test/kmdf/1394/common.h new file mode 100644 index 0000000..eea173a --- /dev/null +++ b/test/kmdf/1394/common.h @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* common code for kmdf/1394 test programs */ + + +/* Source: WDK/src_5239/kmdf/1394/common.h, line 24. */ +/* #if _1394VDEV_DRIVER_ */ +/* #define _DRIVERNAME_ "1394VDEV" */ +/* #else */ +/* #define _DRIVERNAME_ "1394DIAG" */ +/* #endif */ + + +/* #define TL_TRACE 0 */ +/* #define TL_WARNING 1 */ +/* #define TL_ERROR 2 */ +/* #define TL_FATAL 3 */ + +/* extern unsigned char t1394DebugLevel; */ + +/* #define TRACE( l, x ) \ */ +/* if( (l) >= t1394DebugLevel ) { \ */ +/* KdPrint( (_DRIVERNAME_ ": ") ); \ */ +/* KdPrint( x ); \ */ +/* } */ + + +/* Source: WDK/src_5239/kmdf/1394/common.h, line 39. */ + +//----------------------------------------------------------------------------- +// 4127 -- Conditional Expression is Constant warning +//----------------------------------------------------------------------------- +#define WHILE(a) \ +while(__pragma(warning(disable:4127)) a __pragma(warning(disable:4127))) + diff --git a/test/kmdf/1394/cromdata_add_remove.c b/test/kmdf/1394/cromdata_add_remove.c new file mode 100644 index 0000000..c6fee0b --- /dev/null +++ b/test/kmdf/1394/cromdata_add_remove.c @@ -0,0 +1,61 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: 1394api_Add_and_Remove_CromData. + Source: 1394api.c::t1394_SetLocalHostProperties, lines 823-985, 959-991 + Expected Result: SAFE. +*****************************************************************************/ +#include "harness.h" +#include "1394.h" + +#define BUFFER_LENGTH 32 + +NTSTATUS +main() +{ + PDEVICE_EXTENSION deviceExtension; + PLIST_ENTRY listEntry; + + deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(DEVICE_EXTENSION)); + InitializeListHead(&(deviceExtension->CromData)); + + // Add some CromDatas to deviceExtension. + while (nondet()) { + PCROM_DATA CromDataNew ; + CromDataNew = (PCROM_DATA) malloc(sizeof(CROM_DATA)); + CromDataNew->Buffer = (PVOID)malloc(sizeof(BUFFER_LENGTH)); + CromDataNew->pMdl = (PMDL)malloc(sizeof(MDL)); + InsertHeadList(&deviceExtension->CromData, &CromDataNew->CromList); + } + + // assert dE->CromData is a dll. + + // - Delete all CromDatas. + // pnp.c:: t1394_EvtDeviceSelfManagedIoCleanup, lines 531-556. + while (!IsListEmpty(&deviceExtension->CromData)) { + + PCROM_DATA CromData; + + // get struct off list + + listEntry = RemoveHeadList(&deviceExtension->CromData); + CromData = CONTAINING_RECORD(listEntry, CROM_DATA, CromList); + + // need to free up everything associated with this allocate... + if (CromData) + { + if (CromData->Buffer) + ExFreePool(CromData->Buffer); + + if (CromData->pMdl) + IoFreeMdl(CromData->pMdl); + + // we already checked CromData + ExFreePool(CromData); + } + } + + // Teardown ... Not implemented yet, will LEAK. + // free(deviceExtension); + return STATUS_SUCCESS; +} diff --git a/test/kmdf/1394/cromdata_add_remove_fs.c b/test/kmdf/1394/cromdata_add_remove_fs.c new file mode 100644 index 0000000..e97873e --- /dev/null +++ b/test/kmdf/1394/cromdata_add_remove_fs.c @@ -0,0 +1,73 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/***************************************************************************** + 1394 Feature: 1394api_Add_and_Remove_CromData. + Source: 1394api.c::t1394_SetLocalHostProperties, lines 823-985, 959-991 + Expected Result: SAFE, LEAKS. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +int d_x = 1; +int d_y = 2; +int d_z = 3; + +#define BUFFER_LENGTH 32 + +NTSTATUS +main() +{ + PDEVICE_EXTENSION deviceExtension; + PLIST_ENTRY listHead, thisEntry; + CROM_DATA *CromData = NULL, *CromDataNew; + + // 0. Setup. + + deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(DEVICE_EXTENSION)); + InitializeListHead(&(deviceExtension->CromData)); + + // 1394api.c, lines 823-985 (without the error-checking). + CromDataNew = (PCROM_DATA) malloc(sizeof(CROM_DATA)); + CromDataNew->Buffer = (PVOID)malloc(sizeof(BUFFER_LENGTH)); + CromDataNew->pMdl = (PMDL)malloc(sizeof(MDL)); + InsertHeadList(&deviceExtension->CromData, &CromDataNew->CromList); + + CromDataNew = (PCROM_DATA) malloc(sizeof(CROM_DATA)); + CromDataNew->Buffer = (PVOID)malloc(sizeof(BUFFER_LENGTH)); + CromDataNew->pMdl = (PMDL)malloc(sizeof(MDL)); + InsertHeadList(&deviceExtension->CromData, &CromDataNew->CromList); + + CromDataNew = (PCROM_DATA) malloc(sizeof(CROM_DATA)); + CromDataNew->Buffer = (PVOID)malloc(sizeof(BUFFER_LENGTH)); + CromDataNew->pMdl = (PMDL)malloc(sizeof(MDL)); + InsertHeadList(&deviceExtension->CromData, &CromDataNew->CromList); + + + // 1394api.c, lines 959-991. + listHead = &deviceExtension->CromData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + CromData = NULL, thisEntry = thisEntry->Flink) + { + int *filter = &d_y; // Could leave un-initialized for a more generic test. + CromData = CONTAINING_RECORD(thisEntry, CROM_DATA, CromList); + if (CromData->hCromData == filter) { + RemoveEntryList(&CromData->CromList); + break; + } + } + if (CromData) { + if (CromData->Buffer) { + free(CromData->Buffer); + } + free(CromData); + } + + // Teardown ... Not implemented yet, will LEAK. + //t1394_EvtDeviceSelfManagedIoCleanup(deviceExtension); + // free(deviceExtension); + + return STATUS_SUCCESS; +} + diff --git a/test/kmdf/1394/free_resources_remove_entry_list.c b/test/kmdf/1394/free_resources_remove_entry_list.c new file mode 100644 index 0000000..17b14c5 --- /dev/null +++ b/test/kmdf/1394/free_resources_remove_entry_list.c @@ -0,0 +1,150 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: free_resources_remove_entry_list. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 679. */ +NTSTATUS +t1394_IsochFreeResources( + PDEVICE_EXTENSION deviceExtension, /* added for SLAyer */ +/* IN WDFDEVICE Device, */ +/* IN WDFREQUEST Request, */ + /* IN */ HANDLE hResource + ) +{ + NTSTATUS ntStatus = STATUS_SUCCESS; +/* PDEVICE_EXTENSION deviceExtension = GetDeviceContext(Device); */ + PIRB pIrb = NULL; + PISOCH_RESOURCE_DATA IsochResourceData = NULL; + PLIST_ENTRY listHead; + PLIST_ENTRY thisEntry; + +/* ENTER("t1394_IsochFreeResources"); */ + +/* TRACE(TL_TRACE, ("hResource = 0x%x\n", hResource)); */ + + pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); + + if (!pIrb) { + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ + ntStatus = STATUS_INSUFFICIENT_RESOURCES; + goto Exit_IsochFreeResources; + } // if + + // remove this one from our list... + + WdfSpinLockAcquire(deviceExtension->IsochResourceSpinLock); + + listHead = &deviceExtension->IsochResourceData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + IsochResourceData = NULL, thisEntry = thisEntry->Flink) + { + IsochResourceData = CONTAINING_RECORD(thisEntry, + ISOCH_RESOURCE_DATA, + IsochResourceList); + + if (IsochResourceData->hResource == hResource) { +/* TRACE(TL_TRACE, ("Removing hResource = 0x%x\n", hResource)); */ + RemoveEntryList(&IsochResourceData->IsochResourceList); + ExFreePool(IsochResourceData); + break; + } + } + + + WdfSpinLockRelease(deviceExtension->IsochResourceSpinLock); + + RtlZeroMemory (pIrb, sizeof (IRB)); +/* pIrb->FunctionNumber = REQUEST_ISOCH_FREE_RESOURCES; */ + pIrb->Flags = 0; +/* pIrb->u.IsochFreeResources.hResource = hResource; */ + +/* ntStatus = t1394_SubmitIrpSynch(deviceExtension->StackIoTarget, Request, pIrb); */ + + if (!NT_SUCCESS(ntStatus)) { + +/* TRACE(TL_ERROR, ("SubmitIrpSync failed = 0x%x\n", ntStatus)); */ + } + +Exit_IsochFreeResources: + + if (pIrb) + { + ExFreePool(pIrb); + } + +/* EXIT("t1394_IsochFreeResources", ntStatus); */ + return(ntStatus); +} // t1394_IsochFreeResources + + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + PDEVICE_EXTENSION devExt ; + NTSTATUS ntStatus = STATUS_SUCCESS; + PISOCH_RESOURCE_DATA pird; + PISOCH_RESOURCE_DATA obj_to_del = NULL; + int choice; + unsigned int count, i; // count=* + + // OS Model init + ntStatus = SLAyer_harness_init(); + + if (NT_SUCCESS(ntStatus)) { + devExt = GetDeviceContext(SL_Device_one); + + InitializeListHead(&(devExt->IsochResourceData)); + + // Add some IsochResourceData off devExt. + // Set obj_to_del to one of these. + for (i=0; iIsochResourceData),&(pird->IsochResourceList)); + } + if (!obj_to_del) obj_to_del = pird; + + ntStatus = t1394_IsochFreeResources(devExt, obj_to_del); + + // Now set obj_to_del to something new. + obj_to_del = (PISOCH_RESOURCE_DATA)malloc(sizeof(ISOCH_RESOURCE_DATA)); + InitializeListHead(&(obj_to_del->IsochResourceList)); + + ntStatus = t1394_IsochFreeResources(devExt, obj_to_del); + + // OS Model teardown + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(ntStatus)); +} + diff --git a/test/kmdf/1394/initialize_list_head.c b/test/kmdf/1394/initialize_list_head.c new file mode 100644 index 0000000..0bbd70d --- /dev/null +++ b/test/kmdf/1394/initialize_list_head.c @@ -0,0 +1,34 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: initialize_list_head. + Source: pnp.c, line 298. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +NTSTATUS +main() +{ + PDEVICE_EXTENSION deviceExtension; + CROM_DATA *data_x, *data_y, *data_z; + PLIST_ENTRY listHead, thisEntry; + + // 0. Initialize devExt. + deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(DEVICE_EXTENSION)); + + // If we don't initialize deviceExtension->CromData, the first + // InsertHeadList goes wrong. + InitializeListHead(&(deviceExtension->CromData)); +/* SL_triple_de_init(deviceExtension,&(deviceExtension->CromData)); */ + + // Note: assert that dE->cromdata is a dll. + free(deviceExtension); + + return STATUS_SUCCESS; +} + + + + diff --git a/test/kmdf/1394/is_on_list_flat.c b/test/kmdf/1394/is_on_list_flat.c new file mode 100644 index 0000000..e7ec3e8 --- /dev/null +++ b/test/kmdf/1394/is_on_list_flat.c @@ -0,0 +1,62 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: t1394_IsOnList. + Source: util.c, line 60. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + +BOOLEAN +t1394_IsOnList( + PLIST_ENTRY Entry, + PLIST_ENTRY List + ) +{ + PLIST_ENTRY TempEntry; + + for( + TempEntry = List->Flink; + TempEntry != List; + TempEntry = TempEntry->Flink + ) + { + if (TempEntry == Entry) + { + /* TRACE(TL_TRACE, ("Entry 0x%x found on list 0x%x\n", Entry, List)); */ + return TRUE; + } + } + + /* TRACE(TL_TRACE, ("Entry 0x%x not found on list 0x%x\n", Entry, List)); */ + return FALSE; +} + + +/* + * Harness. + */ +int main () +{ + int result; + int length, i; + PLIST_ENTRY entry, ll, tmp; + + // Create a list of some size; 'entry' is one of these elements. + ll = (PLIST_ENTRY) malloc (sizeof(LIST_ENTRY)) ; + InitializeListHead(ll); + entry = ll; + + for (i=0; iFlink; + TempEntry != List; + TempEntry = TempEntry->Flink + ) + { + if (TempEntry == Entry) + { + /* TRACE(TL_TRACE, ("Entry 0x%x found on list 0x%x\n", Entry, List)); */ + return TRUE; + } + } + + /* TRACE(TL_TRACE, ("Entry 0x%x not found on list 0x%x\n", Entry, List)); */ + return FALSE; +} + + +/* + * Harness. + */ +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main () +{ + PDEVICE_EXTENSION devExt; + int result; + int length, i; + PISOCH_DETACH_DATA entry; + NTSTATUS ntStatus; + + // OS Model init + ntStatus = SLAyer_harness_init(); + + if (NT_SUCCESS(ntStatus)) { + devExt = GetDeviceContext(SL_Device_one); + + InitializeListHead(& (devExt->IsochDetachData)); + + // Create a list of some size; + // 'entry' is one of these elements. + for (i=0; iDeviceExtension = devExt; + if (nondet ()) entry = tmp; + InsertHeadList(&(devExt->IsochDetachData),&(tmp->IsochDetachList)) ; + } + + result = t1394_IsOnList(&(entry->IsochDetachList),&devExt->IsochDetachData); + } + + return (NT_SUCCESS(ntStatus)); + //return ntStatus ; +} diff --git a/test/kmdf/1394/isoch_detach_data_shares_devext.c b/test/kmdf/1394/isoch_detach_data_shares_devext.c new file mode 100644 index 0000000..a03b20d --- /dev/null +++ b/test/kmdf/1394/isoch_detach_data_shares_devext.c @@ -0,0 +1,96 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: IsochDetachDatas share devExt. + Source: isochapi.c, lines + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + NTSTATUS status; + PDEVICE_EXTENSION devExt; + PLIST_ENTRY listHead, thisEntry; + BOOLEAN devExt_same = TRUE; + + // OS Model init + status = SLAyer_harness_init(); + + if (NT_SUCCESS(status)) { + devExt = GetDeviceContext(SL_Device_one); + + // Setup: cons some IsochDetachDatas, all pointing to devExt. + // Use _SLAyer_malloc rather than ExAllocate to definitely alloc. + InitializeListHead(&(devExt->IsochDetachData)); + + while (nondet()) { + PISOCH_DETACH_DATA IsochDetachDataNew; + // isochapi, line 408, except we've had to cast the Alloc. + IsochDetachDataNew = _SLAyer_malloc(sizeof(ISOCH_DETACH_DATA)); + + // isochapi, line 444. + IsochDetachDataNew->DeviceExtension = devExt; + + // isochapi, line 432. + InsertHeadList(&devExt->IsochDetachData, + &IsochDetachDataNew->IsochDetachList); + } + + // An abstraction of IsochTimeout. There a given IsochDetachData's + // DeviceExtension is checked for allocated-ness. Here, we check that all + // DeviceExtensions are the same as devExt. + listHead = &(devExt->IsochDetachData); + for (thisEntry = listHead->Flink; + thisEntry != listHead; + thisEntry = thisEntry->Flink) + { + PISOCH_DETACH_DATA IsochDetachData = + CONTAINING_RECORD(thisEntry, ISOCH_DETACH_DATA, IsochDetachList) ; + devExt_same = + devExt_same && (devExt == IsochDetachData->DeviceExtension); + } + + assert( devExt_same ); + + + // Teardown. + while (!IsListEmpty(&(devExt->IsochDetachData))) { + PLIST_ENTRY listEntry = RemoveHeadList(&(devExt->IsochDetachData)); + + PISOCH_DETACH_DATA IsochDetachData = CONTAINING_RECORD (listEntry, + ISOCH_DETACH_DATA, + IsochDetachList); + + free(IsochDetachData); + } + + // OS Model teardown + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(status)); +} + diff --git a/test/kmdf/1394/set_local_properties_plist_entry.c b/test/kmdf/1394/set_local_properties_plist_entry.c new file mode 100644 index 0000000..b83354c --- /dev/null +++ b/test/kmdf/1394/set_local_properties_plist_entry.c @@ -0,0 +1,92 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: 1394api_InsertHeadList, 1394api_RemoveEntryList. + Source: 1394api.c, lines 954, 974. + Expected Result: SAFE, MAY LEAK. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +int d_x = 1; +int d_y = 2; +int d_z = 3; + +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + NTSTATUS status; + PDEVICE_EXTENSION deviceExtension; + CROM_DATA *data_x, *data_y, *data_z; + PLIST_ENTRY listHead, thisEntry; + + // OS Model init + status = SLAyer_harness_init(); + + if (NT_SUCCESS(status)) { + // 0. Initialize devExt. + deviceExtension = GetDeviceContext(SL_Device_one); + + // 1. Add some CromDatas. + data_x = (PCROM_DATA)malloc(sizeof(CROM_DATA)); + data_x->Buffer = (PVOID)malloc(sizeof(int)); + data_x->pMdl = (PMDL)malloc(sizeof(MDL)); + data_x->hCromData = &d_x; + data_y = (PCROM_DATA)malloc(sizeof(CROM_DATA)); + data_y->Buffer = (PVOID)malloc(sizeof(int)); + data_y->pMdl = (PMDL)malloc(sizeof(MDL)); + data_y->hCromData = &d_y; + data_z = (PCROM_DATA)malloc(sizeof(CROM_DATA)); + data_z->Buffer = (PVOID)malloc(sizeof(int)); + data_z->pMdl = (PMDL)malloc(sizeof(MDL)); + data_z->hCromData = &d_z; + + InitializeListHead(&(deviceExtension->CromData)); + InitializeListHead(&(data_x->CromList)); + InitializeListHead(&(data_y->CromList)); + InitializeListHead(&(data_z->CromList)); + + InsertHeadList(&deviceExtension->CromData, &data_x->CromList); + InsertHeadList(&deviceExtension->CromData, &data_y->CromList); + InsertHeadList(&deviceExtension->CromData, &data_z->CromList); + + // 2. Delete some CromDatas. + listHead = &deviceExtension->CromData; + + for(thisEntry = listHead->Flink; + thisEntry != listHead; + thisEntry = thisEntry->Flink) + { + int *filter = &d_y; // Could leave un-initialized for a more generic test. + CROM_DATA *CromData = CONTAINING_RECORD(thisEntry, CROM_DATA, CromList); + if (CromData->hCromData == filter) { + RemoveEntryList(&CromData->CromList); + break; + } + } + + // OS Model teardown + SLAyer_harness_teardown(); + } + + // Note: Currently we LEAK; should teardown here. + return (NT_SUCCESS(status)); +} diff --git a/test/kmdf/1394/timeout_remove_entry_list.c b/test/kmdf/1394/timeout_remove_entry_list.c new file mode 100644 index 0000000..a4f99c0 --- /dev/null +++ b/test/kmdf/1394/timeout_remove_entry_list.c @@ -0,0 +1,275 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: timeout_remove_entry_list. + Expected Result: SAFE, MAY LEAK. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + + +/* Source: WDK/src_5239/kmdf/1394/util.c, line 60. */ +BOOLEAN +t1394_IsOnList( + PLIST_ENTRY Entry, + PLIST_ENTRY List + ) +{ + PLIST_ENTRY TempEntry; + + for( + TempEntry = List->Flink; + TempEntry != List; + TempEntry = TempEntry->Flink + ) + { + if (TempEntry == Entry) + { +/* TRACE(TL_TRACE, ("Entry 0x%x found on list 0x%x\n", Entry, List)); */ + return TRUE; + } + } + +/* TRACE(TL_TRACE, ("Entry 0x%x not found on list 0x%x\n", Entry, List)); */ + return FALSE; +} + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 1238. */ +void +t1394_IsochCleanup( + /* IN */ PISOCH_DETACH_DATA IsochDetachData + ) +{ + ULONG i; + PDEVICE_EXTENSION DeviceExtension; + +/* ENTER("t1394_IsochCleanup"); */ + +/* DeviceExtension = IsochDetachData->DeviceExtension; */ + + // + // see if we need to detach this buffer + // + if ((!IsochDetachData) || (!DeviceExtension)) + { + goto Exit_IsochDetachBuffers; + } + +/* if (IsochDetachData->bDetach) */ { + +/* PIRB pIrb; */ +/* NTSTATUS ntStatus; */ +/* PIO_STACK_LOCATION NextIrpStack; */ + +/* pIrb = ExAllocatePoolWithTag(NonPagedPool, sizeof(IRB), POOLTAG_1394); */ + +/* if (!pIrb) { */ + +/* TRACE(TL_ERROR, ("Failed to allocate pIrb!\n")); */ +/* TRACE(TL_WARNING, ("Can't detach buffer!\n")); */ +/* ntStatus = STATUS_INSUFFICIENT_RESOURCES; */ +/* goto Exit_IsochDetachBuffers; */ +/* } // if */ + + // save the irb in our detach data context +/* IsochDetachData->DetachIrb = pIrb; */ + +/* RtlZeroMemory (pIrb, sizeof (IRB)); */ +/* pIrb->FunctionNumber = REQUEST_ISOCH_DETACH_BUFFERS; */ +/* pIrb->Flags = 0; */ +/* pIrb->u.IsochDetachBuffers.hResource = IsochDetachData->hResource; */ +/* pIrb->u.IsochDetachBuffers.nNumberOfDescriptors = IsochDetachData->numIsochDescriptors; */ +/* pIrb->u.IsochDetachBuffers.pIsochDescriptor = IsochDetachData->IsochDescriptor; */ + +/* NextIrpStack = IoGetNextIrpStackLocation(IsochDetachData->newIrp); */ +/* NextIrpStack->MajorFunction = IRP_MJ_INTERNAL_DEVICE_CONTROL; */ +/* NextIrpStack->Parameters.DeviceIoControl.IoControlCode = IOCTL_1394_CLASS; */ +/* NextIrpStack->Parameters.Others.Argument1 = pIrb; */ + +/* IoSetCompletionRoutine( IsochDetachData->newIrp, */ +/* t1394_IsochDetachCompletionRoutine, */ +/* IsochDetachData, */ +/* TRUE, */ +/* TRUE, */ +/* TRUE */ +/* ); */ + +/* IoCallDriver(DeviceExtension->StackDeviceObject, IsochDetachData->newIrp); */ + } +/* else */ { + +/* TRACE(TL_TRACE, ("Complete Irp.\n")); */ + +/* if (IsochDetachData->AttachIrb) */ +/* { */ +/* ExFreePool(IsochDetachData->AttachIrb); */ +/* } */ + +/* for (i=0; inumIsochDescriptors; i++) */ +/* { */ +/* if (IsochDetachData->IsochDescriptor[i].Mdl) */ +/* { */ +/* IoFreeMdl(IsochDetachData->IsochDescriptor[i].Mdl); */ +/* } */ +/* } */ + +/* ExFreePool(IsochDetachData->IsochDescriptor); */ + + //IsochDetachData->Irp->IoStatus.Status = IsochDetachData->AttachStatus; + + // only set this if its a success... +/* if (NT_SUCCESS(IsochDetachData->AttachStatus)) */ + { + //IsochDetachData->Irp->IoStatus.Information = IsochDetachData->outputBufferLength; + } + + // + // Complete original Irp and free the one we allocated in + // IsochAttachBuffers + // +/* WdfRequestCompleteWithInformation(IsochDetachData->Request, */ +/* IsochDetachData->AttachStatus, */ +/* IsochDetachData->outputBufferLength); */ +/* IoFreeIrp (IsochDetachData->newIrp); */ + + // all done with IsochDetachData, lets deallocate it... + ExFreePool(IsochDetachData); + } + +Exit_IsochDetachBuffers: + +/* EXIT("t1394_IsochCleanup", 0) */; +} // t1394_IsochCleanup + + +/* Source: WDK/src_5239/kmdf/1394/isochapi.c, line 1178. */ +void +t1394_IsochTimeout( + PDEVICE_EXTENSION DeviceExtension, /* added for SLAyer */ +/* IN PKDPC Dpc, */ + /* IN */ PISOCH_DETACH_DATA IsochDetachData/* , */ +/* IN PVOID SystemArgument1, */ +/* IN PVOID SystemArgument2 */ + ) +{ +/* PDEVICE_EXTENSION DeviceExtension; */ + +/* UNREFERENCED_PARAMETER(Dpc); */ +/* UNREFERENCED_PARAMETER(SystemArgument1); */ +/* UNREFERENCED_PARAMETER(SystemArgument2); */ + +/* ENTER("t1394_IsochTimeout"); */ +/* TRACE(TL_WARNING, ("Isoch Timeout!\n")); */ + + // + // ISSUE: the device extension we are referencing comes from the IsochDetachData + // but it is possible this memory has been freed before we enter this function. + // The only way to check is to validate against our DeviceExtension->IsochDetachList + // but if the IsochDetachData has been freed then that won't be accessible + // +/* DeviceExtension = IsochDetachData->DeviceExtension; */ + if (DeviceExtension) + { + // make sure nobody else has already handled this request yet + + WdfSpinLockAcquire(DeviceExtension->IsochSpinLock); + if (t1394_IsOnList(&IsochDetachData->IsochDetachList, &DeviceExtension->IsochDetachData)) + { + RemoveEntryList(&IsochDetachData->IsochDetachList); + + WdfSpinLockRelease(DeviceExtension->IsochSpinLock); + + +/* if(KeCancelTimer(&IsochDetachData->Timer)) */ + { + +/* TRACE(TL_TRACE, ("IsochTimeout: IsochDetachData = 0x%x\n", IsochDetachData)); */ +/* TRACE(TL_TRACE, ("IsochTimeout: IsochDetachData->Irp = 0x%x\n", IsochDetachData->Request)); */ +/* TRACE(TL_TRACE, ("IsochTimeout: IsochDetachData->newIrp = 0x%x\n", IsochDetachData->newIrp)); */ + + // need to save the status of the attach + // we'll clean up in the same spot for success's and timeout's +/* IsochDetachData->AttachStatus = STATUS_TIMEOUT; */ + t1394_IsochCleanup(IsochDetachData); + } + } + else + { + + WdfSpinLockRelease(DeviceExtension->IsochSpinLock); + + } + } + +/* EXIT("t1394_IsochTimeout", 0); */ +} // t1394_IsochTimeout + + +/* + Harness +*/ +NTSTATUS SLAyer_harness_init() +{ + PWDFDEVICE_INIT DInit; + WDF_OBJECT_ATTRIBUTES DAttrib; + WDFDEVICE Device; + NTSTATUS status; + + // malloc SL_Device_one + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&DAttrib,DEVICE_EXTENSION); + status = WdfDeviceCreate(&DInit,&DAttrib,&Device); + return status; +} + +void SLAyer_harness_teardown() +{ + free(SL_Device_one->Context); + free(SL_Device_one); +} + +int main() +{ + PDEVICE_EXTENSION deviceExtension ; + PISOCH_DETACH_DATA pidd; + PISOCH_DETACH_DATA obj_to_del = NULL; + int choice; + unsigned int count, i; + NTSTATUS status; + + // OS Model init + status = SLAyer_harness_init(); + + if (NT_SUCCESS(status)) { + deviceExtension = GetDeviceContext(SL_Device_one); + + InitializeListHead(&(deviceExtension->IsochDetachData)); + + // Add some IsochDetachData off deviceExtension. + // Set obj_to_del to one of these. + for (i=0; iDeviceExtension = deviceExtension; + if (choice) obj_to_del = pidd; + InsertHeadList(&(deviceExtension->IsochDetachData), + &(pidd->IsochDetachList)); + } + if (!obj_to_del) obj_to_del = pidd; + + t1394_IsochTimeout(deviceExtension, obj_to_del); + + // Now set obj_to_del to a new IsochDetachData. + obj_to_del = (PISOCH_DETACH_DATA)malloc(sizeof(ISOCH_DETACH_DATA)); + obj_to_del->DeviceExtension = deviceExtension; + InitializeListHead(&(obj_to_del->IsochDetachList)); + + t1394_IsochTimeout(deviceExtension, obj_to_del); + + // OS Model teardown + SLAyer_harness_teardown(); + } + + return (NT_SUCCESS(status));; + +} diff --git a/test/kmdf/1394/wdf_device_create.c b/test/kmdf/1394/wdf_device_create.c new file mode 100644 index 0000000..59adb2b --- /dev/null +++ b/test/kmdf/1394/wdf_device_create.c @@ -0,0 +1,120 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: wdf_device_create. + Source: 1394samp.c, line 105. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include <1394.h> + +/* + * Stub of function at pnp.c, line 26. + */ +NTSTATUS +t1394_EvtDeviceAdd( + /* IN */ WDFDRIVER Driver, + /* IN */ PWDFDEVICE_INIT DeviceInit + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 308. +NTSTATUS +t1394_EvtPrepareHardware ( + WDFDEVICE Device, + WDFCMRESLIST Resources, + WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 354. +NTSTATUS +t1394_EvtReleaseHardware( + /* IN */ WDFDEVICE Device, + /* IN */ WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 379. +NTSTATUS +t1394_EvtDeviceD0Entry( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE PreviousState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 450. +NTSTATUS +t1394_EvtDeviceD0Exit( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE TargetState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 499. +VOID +t1394_EvtDeviceSelfManagedIoCleanup( + /* IN */ WDFDEVICE Device + ) +{ + return; +} + + +/***************************************************************************** + Harness. + *****************************************************************************/ +int main () +{ + WDFDEVICE_INIT DeviceInit; + NTSTATUS status = STATUS_SUCCESS; + PDEVICE_EXTENSION deviceExtension; + WDF_PNPPOWER_EVENT_CALLBACKS pnpPowerCallbacks; + WDF_OBJECT_ATTRIBUTES fdoAttributes; + WDFDEVICE device; + + // Initialize the PnpPowerCallbacks structure. + WDF_PNPPOWER_EVENT_CALLBACKS_INIT(&pnpPowerCallbacks); + pnpPowerCallbacks.EvtDevicePrepareHardware = t1394_EvtPrepareHardware; + pnpPowerCallbacks.EvtDeviceReleaseHardware = t1394_EvtReleaseHardware; + pnpPowerCallbacks.EvtDeviceSelfManagedIoCleanup = t1394_EvtDeviceSelfManagedIoCleanup; + pnpPowerCallbacks.EvtDeviceD0Entry = t1394_EvtDeviceD0Entry; + pnpPowerCallbacks.EvtDeviceD0Exit = t1394_EvtDeviceD0Exit; + + // Register the PnP and power callbacks. Power policy related callbacks + // SI: impl - implies that WDFDEVICE_INIT contains a WF_PNPPOWER_EVENT_CALLBACKS. + // And that this InitSet call initializes this part to pnpPowerCallbacks's + // content. + WdfDeviceInitSetPnpPowerEventCallbacks(&DeviceInit, &pnpPowerCallbacks); + //WdfDeviceInitSetExclusive(DeviceInit, FALSE); + + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&fdoAttributes, DEVICE_EXTENSION); + + // Implies that WDFDEVICE must contain: + // - DEVICE_INIT + // - WDF_OBJECT_ATTRIBUTES + // - The ContextTypeInfo contains the meta-data of DEVICE_EXTENSION. + // So an additional void* ptr in WDFDEVICE could contain an + // instance of DEVICE_EXTENSINON. + status = WdfDeviceCreate(&DeviceInit, &fdoAttributes, &device); + if ( !NT_SUCCESS(status)) { + //TRACE(TL_ERROR, ("WdfDeviceInitialize failed %x\n", status)); + } + + if (NT_SUCCESS(status)) { + free(SL_Device_one->Context); + free(SL_Device_one); + } + + return (NT_SUCCESS(status)); +} diff --git a/test/kmdf/1394/wdf_device_init_set_pnp_power_event_callbacks.c b/test/kmdf/1394/wdf_device_init_set_pnp_power_event_callbacks.c new file mode 100644 index 0000000..29452fb --- /dev/null +++ b/test/kmdf/1394/wdf_device_init_set_pnp_power_event_callbacks.c @@ -0,0 +1,84 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 CoveragePoint: wdf_device_init_set_pnp_event_callbacks. + Source: pnp.c, line 91. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +// Stub of function at pnp.c, line 308. +NTSTATUS +t1394_EvtPrepareHardware ( + WDFDEVICE Device, + WDFCMRESLIST Resources, + WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 354. +NTSTATUS +t1394_EvtReleaseHardware( + /* IN */ WDFDEVICE Device, + /* IN */ WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 379. +NTSTATUS +t1394_EvtDeviceD0Entry( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE PreviousState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 450. +NTSTATUS +t1394_EvtDeviceD0Exit( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE TargetState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 499. +VOID +t1394_EvtDeviceSelfManagedIoCleanup( + /* IN */ WDFDEVICE Device + ) +{ + return; +} + + +/***************************************************************************** + Harness. + *****************************************************************************/ + +int main (int argc, char* argv[]) +{ + WDFDEVICE_INIT DeviceInit; + WDF_PNPPOWER_EVENT_CALLBACKS callbacks; + + WDF_PNPPOWER_EVENT_CALLBACKS_INIT(&callbacks); + + callbacks.EvtDevicePrepareHardware = t1394_EvtPrepareHardware; + callbacks.EvtDeviceReleaseHardware = t1394_EvtReleaseHardware; + + callbacks.EvtDeviceSelfManagedIoCleanup = t1394_EvtDeviceSelfManagedIoCleanup; + + callbacks.EvtDeviceD0Entry = t1394_EvtDeviceD0Entry; + callbacks.EvtDeviceD0Exit = t1394_EvtDeviceD0Exit; + + WdfDeviceInitSetPnpPowerEventCallbacks(&DeviceInit, &callbacks); + + return STATUS_SUCCESS; +} diff --git a/test/kmdf/1394/wdf_driver_config_init.c b/test/kmdf/1394/wdf_driver_config_init.c new file mode 100644 index 0000000..3272775 --- /dev/null +++ b/test/kmdf/1394/wdf_driver_config_init.c @@ -0,0 +1,36 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: WDF_DRIVER_CONFIG_INIT. + Source: %SLAM%/WDK/inc/wdf/kmdf/1.9/, line 123. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +/* + * Stub of function at pnp.c, line 26. + */ +NTSTATUS +t1394_EvtDeviceAdd( + /* IN */ WDFDRIVER Driver, + /* IN */ PWDFDEVICE_INIT DeviceInit + ) +{ + return STATUS_SUCCESS; +} + + +/* + * Harness. + */ +int main () +{ + WDF_DRIVER_CONFIG config; + + WDF_DRIVER_CONFIG_INIT( + &config, + t1394_EvtDeviceAdd + ); + +} diff --git a/test/kmdf/1394/wdf_driver_create.c b/test/kmdf/1394/wdf_driver_create.c new file mode 100644 index 0000000..b977926 --- /dev/null +++ b/test/kmdf/1394/wdf_driver_create.c @@ -0,0 +1,53 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 Feature: WdfDriverCreate. + Source: 1394samp.c, line 75. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +/* + * Stub of function at pnp.c, line 26. + */ +NTSTATUS +t1394_EvtDeviceAdd( + /* IN */ WDFDRIVER Driver, + /* IN */ PWDFDEVICE_INIT DeviceInit + ) +{ + return STATUS_SUCCESS; +} + +void SLAyer_harness_teardown() +{ + if (NULL != SL_Driver->Context) { free(SL_Driver->Context); } + free(SL_Driver); +} + +/***************************************************************************** + Harness. + *****************************************************************************/ +int main () +{ + NTSTATUS ntStatus; + PUNICODE_STRING RegistryPath; + PDRIVER_OBJECT DriverObject; + WDF_DRIVER_CONFIG config; + + WDF_DRIVER_CONFIG_INIT(&config, + t1394_EvtDeviceAdd + ); + + ntStatus = WdfDriverCreate(DriverObject, + RegistryPath, + WDF_NO_OBJECT_ATTRIBUTES, + &config, + WDF_NO_HANDLE + ); + + SLAyer_harness_teardown(); + + return ntStatus; +} diff --git a/test/kmdf/1394/wdf_object_attributes_init_context_type.c b/test/kmdf/1394/wdf_object_attributes_init_context_type.c new file mode 100644 index 0000000..da13d44 --- /dev/null +++ b/test/kmdf/1394/wdf_object_attributes_init_context_type.c @@ -0,0 +1,74 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 CoveragePoint: wdf_device_init_set_pnp_event_callbacks. + Source: pnp.c, line 91. + Expected Result: SAFE. + *****************************************************************************/ + +#include "harness.h" +#include "1394.h" + +// Stub of function at pnp.c, line 308. +NTSTATUS +t1394_EvtPrepareHardware ( + WDFDEVICE Device, + WDFCMRESLIST Resources, + WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 354. +NTSTATUS +t1394_EvtReleaseHardware( + /* IN */ WDFDEVICE Device, + /* IN */ WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 379. +NTSTATUS +t1394_EvtDeviceD0Entry( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE PreviousState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 450. +NTSTATUS +t1394_EvtDeviceD0Exit( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE TargetState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 499. +VOID +t1394_EvtDeviceSelfManagedIoCleanup( + /* IN */ WDFDEVICE Device + ) +{ + return; +} + +/***************************************************************************** + Harness. + *****************************************************************************/ +int main (int argc, char* argv[]) +{ + NTSTATUS status = STATUS_SUCCESS; + //PDEVICE_EXTENSION deviceExtension; + WDF_OBJECT_ATTRIBUTES fdoAttributes; + + WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(&fdoAttributes, DEVICE_EXTENSION); + + return STATUS_SUCCESS; +} diff --git a/test/kmdf/1394/wdf_pnppower_event_callbacks.c b/test/kmdf/1394/wdf_pnppower_event_callbacks.c new file mode 100644 index 0000000..f889ee5 --- /dev/null +++ b/test/kmdf/1394/wdf_pnppower_event_callbacks.c @@ -0,0 +1,84 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + 1394 CoveragePoint: wdf_pnp_power_event_callback_zero, + wdf_pnp_power_event_callback_init. + Source: pnp.c, lines 66-85. + Expected Result: SAFE. + *****************************************************************************/ +#include "harness.h" +#include "1394.h" + +// Stub of function at pnp.c, line 308. +NTSTATUS +t1394_EvtPrepareHardware ( + WDFDEVICE Device, + WDFCMRESLIST Resources, + WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 354. +NTSTATUS +t1394_EvtReleaseHardware( + /* IN */ WDFDEVICE Device, + /* IN */ WDFCMRESLIST ResourcesTranslated + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 379. +NTSTATUS +t1394_EvtDeviceD0Entry( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE PreviousState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 450. +NTSTATUS +t1394_EvtDeviceD0Exit( + /* IN */ WDFDEVICE Device, + /* IN */ WDF_POWER_DEVICE_STATE TargetState + ) +{ + return STATUS_SUCCESS; +} + +// Stub of function at pnp.c, line 499. +VOID +t1394_EvtDeviceSelfManagedIoCleanup( + /* IN */ WDFDEVICE Device + ) +{ + return; +} + +/***************************************************************************** + Harness. + *****************************************************************************/ + +int main (int argc, char* argv[]) +{ + WDF_PNPPOWER_EVENT_CALLBACKS* callbacks = + (PWDF_PNPPOWER_EVENT_CALLBACKS)malloc(sizeof(WDF_PNPPOWER_EVENT_CALLBACKS)); + + WDF_PNPPOWER_EVENT_CALLBACKS_INIT(callbacks); + + callbacks->EvtDevicePrepareHardware = t1394_EvtPrepareHardware; + callbacks->EvtDeviceReleaseHardware = t1394_EvtReleaseHardware; + + callbacks->EvtDeviceSelfManagedIoCleanup = t1394_EvtDeviceSelfManagedIoCleanup; + + callbacks->EvtDeviceD0Entry = t1394_EvtDeviceD0Entry; + callbacks->EvtDeviceD0Exit = t1394_EvtDeviceD0Exit; + + free(callbacks) ; + + return STATUS_SUCCESS; +} diff --git a/test/kmdf/harness.h b/test/kmdf/harness.h new file mode 100644 index 0000000..f0393d2 --- /dev/null +++ b/test/kmdf/harness.h @@ -0,0 +1,7202 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + harness.h is a basic kmdf implementation. + + We can assume that the kmdf environment the driver runs in, is + safe. What we're trying to catch are the driver's unsafe behaviour. + + A large part of the implementation here is just skip. But: malloc is + implemented as malloc, free as free. The harness malloc functions, + like ExAllocatePool, WdfIoCreateCreate, are implemented to allow + malloc to fail. (The don't-fail branch of these functions calls + _SLAyer_malloc, whose spec is to always succeed.) + + Definitions are listed in the order in which they appear if you + #include . Search for "File:" to find this boundary. + + Search for "Patch:" to find additions/deletions/edits to the original + File. Search for "ToDo" to find missing items. (ToDo: should file PS bugs + for them.) + + If you're adding/editing defns, please keep to these conventions. + */ +#ifndef _HARNESS_H_ +#define _HARNESS_H_ + +#include "slayer_intrinsics.h" + +/* + +Comment: + +We're defining kmdf functions based on need, as the drivers we run on +turn up more of them. We find functions by running: + + $ export PRE=Rtl && \ + grep $PRE *.[ch] | sed "s#.*$PRE\([^(]*\).*#$PRE\1#"|sort|uniq > $PRE.1394 + +for every prefix (Ex, Hal, Io, Ke, Mm, Ps, Rtl, Se, Wdf, Wdm, Zw, +...). And then manually editing the results. + +*/ + +/****************************************************************************** + File: OS Model harness. + + Global state, mimicking kmdf. We have these pointers so as to keep a + handle on these wdf objects. + +******************************************************************************/ + +/* Driver Object. + We only ever have one Driver object. */ + +/* Fwd declaration of types used in OS Model state. */ +typedef struct _SLAyer_WDFOBJECT *WDFDRIVER; +WDFDRIVER SL_Driver ; + +/* +Device Objects + +For the sake of bus drivers, we allow two device objects: +SL_Device_one is Fdo, and SL_Device_two is the child pdo. (We used to +have only one, but toaster can attach many child PDOs. The attach is +not the problem, but toaster also detaches.) +*/ +int SL_devices_zero = 0; // If we init these constants, +int SL_devices_one = 1; // then WdfDriverCreate can test against them. +int SL_devices_two = 2; + +int SL_num_of_devices = 0; // start state + +typedef struct _SLAyer_WDFOBJECT *WDFDEVICE; +WDFDEVICE SL_Device_one = NULL; +WDFDEVICE SL_Device_two = NULL; +WDFDEVICE SL_Device = NULL ; /* should be subsumed by SL_Device_one */ + +/* IoTarget */ +typedef struct _SLAyer_WDFOBJECT *WDFIOTARGET; +WDFIOTARGET SL_IoTarget ; + +/* Queue */ +typedef struct _SLAyer_WDFOBJECT *WDFQUEUE; +WDFQUEUE SL_Queue; + +/* Timer */ +typedef struct _SLAyer_WDFOBJECT *WDFTIMER; +WDFTIMER SL_Timer ; + +/* DeviceInit */ +// PS #644 DeviceInit lifetime +typedef struct _WDFDEVICE_INIT **PWDFDEVICE_INIT; +PWDFDEVICE_INIT SL_WdfDeviceInit; + +/****************************************************************************** + * File: + ******************************************************************************/ + +// body for returning non-det of any T +#define SLAyer_nondetT(T) T x; return x + +/****************************************************************************** + * File: CPP-out some ESP + ******************************************************************************/ +// PS #635: switch off analysis_assume +#define __analysis_assume(x) + + + +/****************************************************************************** + * File: guiddef.h + ******************************************************************************/ +typedef struct _GUID { + unsigned long Data1; + unsigned short Data2; + unsigned short Data3; + unsigned char Data4[ 8 ]; +} GUID; +#define DEFINE_GUID(name, l, w1, w2, b1, b2, b3, b4, b5, b6, b7, b8) \ + /*EXTERN_C*/ const GUID /*DECLSPEC_SELECTANY*/ name \ + = { l, w1, w2, { b1, b2, b3, b4, b5, b6, b7, b8 } } + +typedef GUID *LPGUID; + +//#define DEFINE_GUID(name, l, w1, w2, b1, b2, b3, b4, b5, b6, b7, b8) \ +// GUID name ; +// /*EXTERN_C*/ const GUID /*DECLSPEC_SELECTANY*/ name \ +// = { l, w1, w2, { b1, b2, b3, b4, b5, b6, b7, b8 } } + +#define __MIDL_CONST const +#define REFGUID const GUID * __MIDL_CONST + +// SLayer implementation of IsEqualGUID. See PS #646. +unsigned int IsEqualGUID(REFGUID pg1, REFGUID pg2) +{ + return (pg1->Data1 == pg2->Data1) && + (pg1->Data2 == pg2->Data2) && + (pg1->Data3 == pg2->Data3); + /* SLAyer: array memory model imprecise, ignore Data4 array.*/ + /* && (pg1->Data4[*] == pg2->Data4[*]) */ +} + +// Mimic pragmas, etc. +// SI: I don't think these are in guiddef.h. + +#define FORCEINLINE + +#define __drv_aliasesMem +#define __drv_functionClass(EVT_WDF_OBJECT_CONTEXT_CLEANUP) +#define __drv_sameIRQL +#define __drv_maxIRQL(DISPATCH_LEVEL) +#define __drv_freesMem(Mem) +//slayer.h now links to assert.h -> crtdefs.h -> sal.h, so these are no longer required +//#define __checkReturn +//#define __in +//#define __inout +//#define __out +//#define __in_opt +#define WDFAPI + +#ifndef __LPCGUID_DEFINED__ +#define __LPCGUID_DEFINED__ +typedef const GUID *LPCGUID; +#endif + +#define IN __in +#define OUT __out + +#define UNREFERENCED_PARAMETER(x) x=x +#define PAGED_CODE() + +/****************************************************************************** + * File: crt + ******************************************************************************/ + +// Mimic crt. +//slayer.h now links to stdlib.h, so this are no longer required +//#define NULL 0 + +typedef unsigned int BOOLEAN; +#define TRUE 1 //(1==1) +#define FALSE 0 //(~(TRUE)) + +/* SI: ASSERTs from toaster's source. They tend to be about length of + buffers, which SLAyer can't do anything about. We drop them for + now, but maybe better to keep them as an assume? */ +#define ASSERT(x) +#define WDFVERIFY(x) + +typedef unsigned int NTSTATUS; + +// Some of these are definedin ntintsafe.h. +typedef long LONG; +typedef unsigned short USHORT; +typedef USHORT *PUSHORT; +typedef unsigned long ULONG; +typedef ULONG *ULONG_PTR; +typedef ULONG *PULONG; +typedef long *PLONGLONG; +typedef long long LONGLONG; +typedef void VOID; +typedef void *PVOID; +#ifndef _SIZE_T_DEFINED +typedef unsigned int size_t; +#endif +#define SIZE_T size_t +typedef unsigned char UCHAR; +typedef unsigned short WCHAR; +typedef char* PCHAR; +typedef char* PUCHAR; +typedef WCHAR* PWCHAR; +typedef WCHAR *PWCH; +typedef WCHAR *PWSTR; +typedef const WCHAR *PCWSTR; +#define CSHORT int +#define USHORT int +typedef unsigned __int64 UINT64, *PUINT64; + +/***************************************************************************** + * File: shared/WTypesbase.h + ****************************************************************************/ +typedef double LONGLONG; +// The implementation of this is different to the one found in system +// header files. There seems to be at least two different +// implementations. See shared/ntdef.h:line 930 and +// shared/WTypesbase.h:166. +typedef struct _LARGE_INTEGER { + // struct { + ULONG LowPart; + LONG HighPart; + // } DUMMYSTRUCTNAME; + // struct { + // ULONG LowPart; + // LONG HighPart; + // } u; + LONGLONG QuadPart; +} LARGE_INTEGER; + +/***************************************************************************** + * File: ntdef.h + ****************************************************************************/ +typedef double ULONGLONG; + +// line 989 +//typedef VOID PHYSICAL_ADDRESS, *PPHYSICAL_ADDRESS; +#define PHYSICAL_ADDRESS void* +#define PPHYSICAL_ADDRESS void** + +/**************************************************************************** + * File: ntstatus.h + ****************************************************************************/ +#define STATUS_SUCCESS 0x0 +#define STATUS_INSUFFICIENT_RESOURCES 0x1 +#define STATUS_INVALID_PARAMETER 0x2 +#define STATUS_MORE_PROCESSING_REQUIRED 0x3 +#define STATUS_BUFFER_TOO_SMALL 0x4 +#define STATUS_PENDING 0x5 +#define STATUS_UNSUCCESSFUL 0x6 +#define STATUS_INVALID_DEVICE_REQUEST 0x7 + +#define STATUS_INVALID_ADDRESS ((NTSTATUS)0xC0000141L) + +#define STATUS_DEVICE_DATA_ERROR ((NTSTATUS)0xC000009CL) +#define STATUS_DEVICE_NOT_READY ((NTSTATUS)0xC00000A3L) +#define STATUS_DEVICE_NOT_CONNECTED ((NTSTATUS)0xC000009DL) +#define STATUS_DEVICE_OFF_LINE ((NTSTATUS)0x80000010L) + +#define STATUS_NOT_SUPPORTED ((NTSTATUS)0xC00000BBL) + +#define STATUS_OBJECT_NAME_EXISTS ((NTSTATUS)0x40000000L) + +#define STATUS_NO_MORE_ENTRIES ((NTSTATUS)0x8000001AL) + +#define STATUS_NO_SUCH_DEVICE ((NTSTATUS)0xC000000EL) +#define STATUS_WMI_READ_ONLY ((NTSTATUS)0xC00002C6L) + +// Copied from line 2317 +#define STATUS_INVALID_PARAMETER_MIX ((NTSTATUS)0xC0000030L) + +// line 5406 +#define STATUS_DEVICE_CONFIGURATION_ERROR ((NTSTATUS)0xC0000182L) + +// Copied from line 7053 +#define STATUS_WMI_ITEMID_NOT_FOUND ((NTSTATUS)0xC0000297L) + +/****************************************************************************** + * File: ntintsafe.h. + ******************************************************************************/ +#define NT_SUCCESS(Status) (Status == STATUS_SUCCESS) + +NTSTATUS RtlSizeTMult( + /* _In_ */ SIZE_T Multiplicand, + /* _In_ */ SIZE_T Multiplier, + /* _Out_ */ SIZE_T *pResult +) +{ + SLAyer_nondetT(NTSTATUS); +} + +/****************************************************************************** + * File: ntdef.h. + ******************************************************************************/ + +typedef char CCHAR; +typedef CCHAR *PCCHAR; + +// Copied from WDK/inc/api/ntdef.h, line 636. +typedef void *HANDLE; +#define DECLARE_HANDLE(name) typedef HANDLE name + +// Copied from WDK/inc/api/ntdef.h, line 1287. +typedef struct _UNICODE_STRING { + unsigned short Length; + unsigned short MaximumLength; + PWSTR Buffer; +} UNICODE_STRING, *PUNICODE_STRING; +typedef const UNICODE_STRING *PCUNICODE_STRING; + +// Copied from $SLAM/WDK/inc/api/ntdef.h, line 1358. +typedef struct _LIST_ENTRY { + struct _LIST_ENTRY *Flink; + struct _LIST_ENTRY *Blink; +} LIST_ENTRY, *PLIST_ENTRY; + +//copied from WDk/inc/shared/ntdef.h, line 1343 +#define UNICODE_NULL ((WCHAR)0) // winnt + +//copied from WDk/inc/shared/ntdef.h, line 1350 + #define DECLARE_CONST_UNICODE_STRING(_var, _string) \ +const WCHAR _var ## _buffer[] = _string; \ +__pragma(warning(push)) \ +__pragma(warning(disable:4221)) __pragma(warning(disable:4204)) \ +const UNICODE_STRING _var = { sizeof(_string) - sizeof(WCHAR), sizeof(_string), (PWCH) _var ## _buffer } \ +__pragma(warning(pop)) + +//copied from WDk/inc/shared/ntdef.h, line 1360 +#define DECLARE_UNICODE_STRING_SIZE(_var, _size) \ +WCHAR _var ## _buffer[_size]; \ +__pragma(warning(push)) \ +__pragma(warning(disable:4221)) __pragma(warning(disable:4204)) \ +UNICODE_STRING _var = { 0, (_size) * sizeof(WCHAR) , _var ## _buffer } \ +__pragma(warning(pop)) + +// line 1398 +typedef struct _SINGLE_LIST_ENTRY { + struct _SINGLE_LIST_ENTRY *Next; +} SINGLE_LIST_ENTRY, *PSINGLE_LIST_ENTRY; + +/**************************************************************************** + * File: ntddk.h + ****************************************************************************/ +// line 5292 +#define FILE_DEVICE_NETWORK 0x00000012 + + // copied from line 5374 + // +// Define the method codes for how buffers are passed for I/O and FS controls +// + +#define METHOD_BUFFERED 0 +#define METHOD_IN_DIRECT 1 +#define METHOD_OUT_DIRECT 2 +#define METHOD_NEITHER 3 + +/****************************************************************************** + * File: winnt.h + ******************************************************************************/ +//copied from line 8560 + +#define STANDARD_RIGHTS_ALL (0x001F0000L) + +/***************************************************************************** + * File: wdm.h + ****************************************************************************/ + +// line 5904 +#define FILE_SHARE_READ 0x00000001 +#define FILE_SHARE_WRITE 0x00000002 + +// line 5967 +#define FILE_OPEN 0x00000001 + +// line 5985 +#define FILE_NON_DIRECTORY_FILE 0x00000040 + +// line 6048 +#define FILE_OCTA_ALIGNMENT 0x0000000f + +// line 6085 +typedef struct _IO_STATUS_BLOCK { + union { + NTSTATUS Status; + PVOID Pointer; + } DUMMYUNIONNAME; + ULONG_PTR Information; +} IO_STATUS_BLOCK, *PIO_STATUS_BLOCK; + +DECLARE_HANDLE(KAFFINITY); + +#define CmResourceTypePort 1 // ResType_IO (0x0002) +#define CmResourceTypeInterrupt 2 // ResType_IRQ (0x0004) +#define CmResourceTypeMemory 3 // ResType_Mem (0x0001) + +// Copied from /cygdrive/c/Program Files (x86)/Windows Kits/8.0/Include/km/wdm.h +// line 8853 +// /cygdrive/c/Program Files (x86)/Windows Kits/8.0/Include/km/wdm.h +// line 8853 +typedef struct _CM_PARTIAL_RESOURCE_DESCRIPTOR { + UCHAR Type; + UCHAR ShareDisposition; + USHORT Flags; + union { + + // + // Range of resources, inclusive. These are physical, bus relative. + // It is known that Port and Memory below have the exact same layout + // as Generic. + // + + struct { + PHYSICAL_ADDRESS Start; + ULONG Length; + } Generic; + + // + // + + struct { + PHYSICAL_ADDRESS Start; + ULONG Length; + } Port; + + // + // + + struct { +#if defined(NT_PROCESSOR_GROUPS) + USHORT Level; + USHORT Group; +#else + ULONG Level; +#endif + ULONG Vector; + KAFFINITY Affinity; + } Interrupt; + + // + // Values for message signaled interrupts are distinct in the + // raw and translated cases. + // + + struct { + union { + struct { +#if defined(NT_PROCESSOR_GROUPS) + USHORT Group; +#else + USHORT Reserved; +#endif + USHORT MessageCount; + ULONG Vector; + KAFFINITY Affinity; + } Raw; + + struct { +#if defined(NT_PROCESSOR_GROUPS) + USHORT Level; + USHORT Group; +#else + ULONG Level; +#endif + ULONG Vector; + KAFFINITY Affinity; + } Translated; + } DUMMYUNIONNAME; + } MessageInterrupt; + + // + // Range of memory addresses, inclusive. These are physical, bus + // relative. The value should be the same as the one passed to + // HalTranslateBusAddress(). + // + + struct { + PHYSICAL_ADDRESS Start; // 64 bit physical addresses. + ULONG Length; + } Memory; + + // + // Physical DMA channel. + // + + struct { + ULONG Channel; + ULONG Port; + ULONG Reserved1; + } Dma; + + struct { + ULONG Channel; + ULONG RequestLine; + UCHAR TransferWidth; + UCHAR Reserved1; + UCHAR Reserved2; + UCHAR Reserved3; + } DmaV3; + + // + // Device driver private data, usually used to help it figure + // what the resource assignments decisions that were made. + // + + struct { + ULONG Data[3]; + } DevicePrivate; + + // + // Bus Number information. + // + + struct { + ULONG Start; + ULONG Length; + ULONG Reserved; + } BusNumber; + + // + // Device Specific information defined by the driver. + // The DataSize field indicates the size of the data in bytes. The + // data is located immediately after the DeviceSpecificData field in + // the structure. + // + + struct { + ULONG DataSize; + ULONG Reserved1; + ULONG Reserved2; + } DeviceSpecificData; + + // The following structures provide support for memory-mapped + // IO resources greater than MAXULONG + struct { + PHYSICAL_ADDRESS Start; + ULONG Length40; + } Memory40; + + struct { + PHYSICAL_ADDRESS Start; + ULONG Length48; + } Memory48; + + struct { + PHYSICAL_ADDRESS Start; + ULONG Length64; + } Memory64; + + struct { + UCHAR Class; + UCHAR Type; + UCHAR Reserved1; + UCHAR Reserved2; + ULONG IdLowPart; + ULONG IdHighPart; + } Connection; + + } u; +} CM_PARTIAL_RESOURCE_DESCRIPTOR, *PCM_PARTIAL_RESOURCE_DESCRIPTOR; + + +// Line: 4398 +// +// Define the various device type values. Note that values used by Microsoft +// Corporation are in the range 0-32767, and 32768-65535 are reserved for use +// by customers. +// + +#define DEVICE_TYPE ULONG +// Line: 4447 +#define FILE_DEVICE_BUS_EXTENDER 0x0000002a + +// Line 5129 +// +// Define the I/O bus interface types. +// + +typedef enum _INTERFACE_TYPE { + InterfaceTypeUndefined = -1, + Internal, + Isa, + Eisa, + MicroChannel, + TurboChannel, + PCIBus, + VMEBus, + NuBus, + PCMCIABus, + CBus, + MPIBus, + MPSABus, + ProcessorInternal, + InternalPowerBus, + PNPISABus, + PNPBus, + Vmcs, + ACPIBus, + MaximumInterfaceType +}INTERFACE_TYPE, *PINTERFACE_TYPE; + +typedef struct _DEVICE_OBJECT { + short Type; + struct _DEVOBJ_EXTENSION * DeviceObjectExtension ; +} DEVICE_OBJECT, *PDEVICE_OBJECT ; + +// Copied from $SLAM/WDK/inc/ddk/wdm.h, line 7403. + +// +// Doubly-linked list manipulation routines. +// + +// +// VOID +// InitializeListHead32( +// PLIST_ENTRY32 ListHead +// ); +// + +#define InitializeListHead32(ListHead) (\ + (ListHead)->Flink = (ListHead)->Blink = PtrToUlong((ListHead))) + +//#if !defined(MIDL_PASS) && !defined(SORTPP_PASS) + +//#define RTL_STATIC_LIST_HEAD(x) LIST_ENTRY x = { &x, &x } + +FORCEINLINE +VOID +InitializeListHead( + __out PLIST_ENTRY ListHead + ) +{ + ListHead->Flink = ListHead->Blink = ListHead; +} + +__checkReturn +BOOLEAN +FORCEINLINE +IsListEmpty( + __in const LIST_ENTRY * ListHead + ) +{ + return (BOOLEAN)(ListHead->Flink == ListHead); +} + +FORCEINLINE +BOOLEAN +RemoveEntryList( + __in PLIST_ENTRY Entry + ) +{ + PLIST_ENTRY Blink; + PLIST_ENTRY Flink; + + Flink = Entry->Flink; + Blink = Entry->Blink; + Blink->Flink = Flink; + Flink->Blink = Blink; + return (BOOLEAN)(Flink == Blink); +} + +FORCEINLINE +PLIST_ENTRY +RemoveHeadList( + __inout PLIST_ENTRY ListHead + ) +{ + PLIST_ENTRY Flink; + PLIST_ENTRY Entry; + + Entry = ListHead->Flink; + Flink = Entry->Flink; + ListHead->Flink = Flink; + Flink->Blink = ListHead; + return Entry; +} + +FORCEINLINE +PLIST_ENTRY +RemoveTailList( + __inout PLIST_ENTRY ListHead + ) +{ + PLIST_ENTRY Blink; + PLIST_ENTRY Entry; + + Entry = ListHead->Blink; + Blink = Entry->Blink; + ListHead->Blink = Blink; + Blink->Flink = ListHead; + return Entry; +} + +FORCEINLINE +VOID +InsertTailList( + __inout PLIST_ENTRY ListHead, + __inout __drv_aliasesMem PLIST_ENTRY Entry + ) +{ + PLIST_ENTRY Blink; + + Blink = ListHead->Blink; + Entry->Flink = ListHead; + Entry->Blink = Blink; + Blink->Flink = Entry; + ListHead->Blink = Entry; +} + +FORCEINLINE +VOID +InsertHeadList( + __inout PLIST_ENTRY ListHead, + __inout __drv_aliasesMem PLIST_ENTRY Entry + ) +{ + PLIST_ENTRY Flink; + + Flink = ListHead->Flink; + Entry->Flink = Flink; + Entry->Blink = ListHead; + Flink->Blink = Entry; + ListHead->Flink = Entry; +} + +FORCEINLINE +VOID +AppendTailList( + __inout PLIST_ENTRY ListHead, + __inout PLIST_ENTRY ListToAppend + ) +{ + PLIST_ENTRY ListEnd = ListHead->Blink; + + ListHead->Blink->Flink = ListToAppend; + ListHead->Blink = ListToAppend->Blink; + ListToAppend->Blink->Flink = ListHead; + ListToAppend->Blink = ListEnd; +} +//copied from WDK/include/km/wdm.h ,line 8032 +typedef enum _SYSTEM_POWER_STATE { + PowerSystemUnspecified = 0, + PowerSystemWorking = 1, + PowerSystemSleeping1 = 2, + PowerSystemSleeping2 = 3, + PowerSystemSleeping3 = 4, + PowerSystemHibernate = 5, + PowerSystemShutdown = 6, + PowerSystemMaximum = 7 +} SYSTEM_POWER_STATE, *PSYSTEM_POWER_STATE; + +//copied from WDK/include/km/wdm.h ,line 8056 +typedef enum _DEVICE_POWER_STATE { + PowerDeviceUnspecified = 0, + PowerDeviceD0, + PowerDeviceD1, + PowerDeviceD2, + PowerDeviceD3, + PowerDeviceMaximum +} DEVICE_POWER_STATE, *PDEVICE_POWER_STATE; + +DECLARE_HANDLE(KAFFINITY); + +// Copied from $SLAM/WDK/inc/ddk/wdm.h, line 16298. +// +// Pool Allocation routines (in pool.c) +// + +typedef enum _POOL_TYPE { + NonPagedPool, + PagedPool, + NonPagedPoolMustSucceed, + DontUseThisType, + NonPagedPoolCacheAligned, + PagedPoolCacheAligned, + NonPagedPoolCacheAlignedMustS, + MaxPoolType, + + // + // Note these per session types are carefully chosen so that the appropriate + // masking still applies as well as MaxPoolType above. + // + + NonPagedPoolSession = 32, + PagedPoolSession = NonPagedPoolSession + 1, + NonPagedPoolMustSucceedSession = PagedPoolSession + 1, + DontUseThisTypeSession = NonPagedPoolMustSucceedSession + 1, + NonPagedPoolCacheAlignedSession = DontUseThisTypeSession + 1, + PagedPoolCacheAlignedSession = NonPagedPoolCacheAlignedSession + 1, + NonPagedPoolCacheAlignedMustSSession = PagedPoolCacheAlignedSession + 1, +} POOL_TYPE; + +#define POOL_COLD_ALLOCATION 256 // Note this cannot encode into the header. + +#define POOL_QUOTA_FAIL_INSTEAD_OF_RAISE 8 +#define POOL_RAISE_IF_ALLOCATION_FAILURE 16 + +// SLAyer: implemented "maybe malloc". +// line 14611 +#define PAGE_SHIFT 12L + +PVOID +ExAllocatePoolWithTag( +/* __in __drv_strictTypeMatch(__drv_typeExpr) */ POOL_TYPE PoolType, +/* __in */ size_t NumberOfBytes, +/* __in */ ULONG Tag + ) +{ + int x; + if (x) { + return _SLAyer_malloc(NumberOfBytes) ; + } else { + return NULL; + } +} + +//_IRQL_requires_max_(PASSIVE_LEVEL) +//DECLSPEC_IMPORT +PVOID +//NTAPI +MmGetSystemRoutineAddress ( + /*_In_*/ PUNICODE_STRING SystemRoutineName + ) +{ + SLAyer_nondetT(PVOID); +} + +VOID +ObDereferenceObject( + /*_In_*/ PVOID Object + ) +{ + return; +} + +// SLAyer: incomplete +NTSTATUS +IoUnregisterPlugPlayNotification( + _In_ __drv_freesMem(Pool) PVOID NotificationEntry + ) +{ + SLAyer_nondetT(NTSTATUS); +} + +/* Reimplementing this myself, as there seems to be no WDF implementation + * to be found. This might well be CORREECT, see wdm.h line 29203. --KK + */ +ULONG +IoWMIDeviceObjectToProviderId( + _In_ PDEVICE_OBJECT DeviceObject + ) +{ + return (ULONG)DeviceObject; +} + +__drv_maxIRQL(DISPATCH_LEVEL) +//NTKERNELAPI +VOID +//NTAPI +ExFreePool( + __in __drv_freesMem(Mem) PVOID P + ) +{ + _SLAyer_free(P); +} + +//#endif + +//#if (NTDDI_VERSION >= NTDDI_WIN2K) + +// Patch: +__drv_maxIRQL(DISPATCH_LEVEL) +//NTKERNELAPI +VOID +ExFreePoolWithTag( + __in __drv_freesMem(Mem) PVOID P, + __in ULONG Tag + ) +{ + _SLAyer_free(P); +} +//#endif + +// SI: stub, shouldn't be used right now. +VOID RtlZeroMemory(VOID* Dest, size_t Len) {} + +VOID RtlCopyMemory( + /*_Out_*/ VOID UNALIGNED *Destination, + /*_In_*/ const VOID UNALIGNED *Source, + /*_In_*/ SIZE_T Length +) +{ +} + +VOID RtlInitUnicodeString(PUNICODE_STRING DestinationString, PCWSTR SourceString) {} + +NTSTATUS +RtlUnicodeStringPrintf(PVOID buffer, char* fmt, ULONG SerialNo) +{ + SLAyer_nondetT(NTSTATUS); +} + +typedef /* __struct_bcount(Size) */ struct _MDL { + struct _MDL *Next; + CSHORT Size; + CSHORT MdlFlags; + // struct _EPROCESS *Process; + PVOID MappedSystemVa; + PVOID StartVa; + ULONG ByteCount; + ULONG ByteOffset; +} MDL, *PMDL; + +// line 19892 +typedef enum _MEMORY_CACHING_TYPE_ORIG { + MmFrameBufferCached = 2 +} MEMORY_CACHING_TYPE_ORIG; + +typedef enum _MEMORY_CACHING_TYPE { + MmNonCached = FALSE, + MmCached = TRUE, + MmWriteCombined = MmFrameBufferCached, + MmHardwareCoherentCached, + MmNonCachedUnordered, // IA64 + MmUSWCCached, + MmMaximumCacheType +} MEMORY_CACHING_TYPE; + +// line 21279. +// +// I/O Request Packet (IRP) definition +// +// Patch: most fields commented out. +typedef struct /* DECLSPEC_ALIGN(MEMORY_ALLOCATION_ALIGNMENT) */ _IRP { + CSHORT Type; + USHORT Size; + + // + // Define the common fields used to control the IRP. + // + + // + // Define a pointer to the Memory Descriptor List (MDL) for this I/O + // request. This field is only used if the I/O is "direct I/O". + // + + PMDL MdlAddress; + + // + // Flags word - used to remember various flags. + // + + ULONG Flags; + +/* // */ +/* // The following union is used for one of three purposes: */ +/* // */ +/* // 1. This IRP is an associated IRP. The field is a pointer to a master */ +/* // IRP. */ +/* // */ +/* // 2. This is the master IRP. The field is the count of the number of */ +/* // IRPs which must complete (associated IRPs) before the master can */ +/* // complete. */ +/* // */ +/* // 3. This operation is being buffered and the field is the address of */ +/* // the system space buffer. */ +/* // */ + +/* union { */ +/* struct _IRP *MasterIrp; */ +/* __volatile LONG IrpCount; */ +/* PVOID SystemBuffer; */ +/* } AssociatedIrp; */ + +/* // */ +/* // Thread list entry - allows queueing the IRP to the thread pending I/O */ +/* // request packet list. */ +/* // */ + +/* LIST_ENTRY ThreadListEntry; */ + +/* // */ +/* // I/O status - final status of operation. */ +/* // */ + +/* IO_STATUS_BLOCK IoStatus; */ + +/* // */ +/* // Requestor mode - mode of the original requestor of this operation. */ +/* // */ + +/* KPROCESSOR_MODE RequestorMode; */ + +/* // */ +/* // Pending returned - TRUE if pending was initially returned as the */ +/* // status for this packet. */ +/* // */ + +/* BOOLEAN PendingReturned; */ + +/* // */ +/* // Stack state information. */ +/* // */ + +/* CHAR StackCount; */ +/* CHAR CurrentLocation; */ + +/* // */ +/* // Cancel - packet has been canceled. */ +/* // */ + +/* BOOLEAN Cancel; */ + +/* // */ +/* // Cancel Irql - Irql at which the cancel spinlock was acquired. */ +/* // */ + +/* KIRQL CancelIrql; */ + +/* // */ +/* // ApcEnvironment - Used to save the APC environment at the time that the */ +/* // packet was initialized. */ +/* // */ + +/* CCHAR ApcEnvironment; */ + +/* // */ +/* // Allocation control flags. */ +/* // */ + +/* UCHAR AllocationFlags; */ + +/* // */ +/* // User parameters. */ +/* // */ + +/* PIO_STATUS_BLOCK UserIosb; */ +/* PKEVENT UserEvent; */ +/* union { */ +/* struct { */ +/* union { */ +/* PIO_APC_ROUTINE UserApcRoutine; */ +/* PVOID IssuingProcess; */ +/* }; */ +/* PVOID UserApcContext; */ +/* } AsynchronousParameters; */ +/* LARGE_INTEGER AllocationSize; */ +/* } Overlay; */ + +/* // */ +/* // CancelRoutine - Used to contain the address of a cancel routine supplied */ +/* // by a device driver when the IRP is in a cancelable state. */ +/* // */ + +/* __volatile PDRIVER_CANCEL CancelRoutine; */ + +/* // */ +/* // Note that the UserBuffer parameter is outside of the stack so that I/O */ +/* // completion can copy data back into the user's address space without */ +/* // having to know exactly which service was being invoked. The length */ +/* // of the copy is stored in the second half of the I/O status block. If */ +/* // the UserBuffer field is NULL, then no copy is performed. */ +/* // */ + +/* PVOID UserBuffer; */ + +/* // */ +/* // Kernel structures */ +/* // */ +/* // The following section contains kernel structures which the IRP needs */ +/* // in order to place various work information in kernel controller system */ +/* // queues. Because the size and alignment cannot be controlled, they are */ +/* // placed here at the end so they just hang off and do not affect the */ +/* // alignment of other fields in the IRP. */ +/* // */ + +/* union { */ + +/* struct { */ + +/* union { */ + +/* // */ +/* // DeviceQueueEntry - The device queue entry field is used to */ +/* // queue the IRP to the device driver device queue. */ +/* // */ + +/* KDEVICE_QUEUE_ENTRY DeviceQueueEntry; */ + +/* struct { */ + +/* // */ +/* // The following are available to the driver to use in */ +/* // whatever manner is desired, while the driver owns the */ +/* // packet. */ +/* // */ + +/* PVOID DriverContext[4]; */ + +/* } ; */ + +/* } ; */ + +/* // */ +/* // Thread - pointer to caller's Thread Control Block. */ +/* // */ + +/* PETHREAD Thread; */ + +/* // */ +/* // Auxiliary buffer - pointer to any auxiliary buffer that is */ +/* // required to pass information to a driver that is not contained */ +/* // in a normal buffer. */ +/* // */ + +/* PCHAR AuxiliaryBuffer; */ + +/* // */ +/* // The following unnamed structure must be exactly identical */ +/* // to the unnamed structure used in the minipacket header used */ +/* // for completion queue entries. */ +/* // */ + +/* struct { */ + +/* // */ +/* // List entry - used to queue the packet to completion queue, among */ +/* // others. */ +/* // */ + +/* LIST_ENTRY ListEntry; */ + +/* union { */ + +/* // */ +/* // Current stack location - contains a pointer to the current */ +/* // IO_STACK_LOCATION structure in the IRP stack. This field */ +/* // should never be directly accessed by drivers. They should */ +/* // use the standard functions. */ +/* // */ + +/* struct _IO_STACK_LOCATION *CurrentStackLocation; */ + +/* // */ +/* // Minipacket type. */ +/* // */ + +/* ULONG PacketType; */ +/* }; */ +/* }; */ + +/* // */ +/* // Original file object - pointer to the original file object */ +/* // that was used to open the file. This field is owned by the */ +/* // I/O system and should not be used by any other drivers. */ +/* // */ + +/* PFILE_OBJECT OriginalFileObject; */ + +/* } Overlay; */ + +/* // */ +/* // APC - This APC control block is used for the special kernel APC as */ +/* // well as for the caller's APC, if one was specified in the original */ +/* // argument list. If so, then the APC is reused for the normal APC for */ +/* // whatever mode the caller was in and the "special" routine that is */ +/* // invoked before the APC gets control simply deallocates the IRP. */ +/* // */ + +/* KAPC Apc; */ + +/* // */ +/* // CompletionKey - This is the key that is used to distinguish */ +/* // individual I/O operations initiated on a single file handle. */ +/* // */ + +/* PVOID CompletionKey; */ + +/* } Tail; */ + +} IRP; + +typedef IRP *PIRP; + +// PS #640 Consider generalizing return values +// Patch: +PMDL IoAllocateMdl( + /* __in_opt */ PVOID VirtualAddress, + /*__in*/ ULONG Length, + /*__in*/ BOOLEAN SecondaryBuffer, + /*__in*/ BOOLEAN ChargeQuota, + /*__inout_opt*/ PIRP Irp +) +{ + int size ; + return _SLAyer_malloc(size) ; +} + +VOID IoFreeMdl (PMDL Mdl) +{ + _SLAyer_free(Mdl); +} + +// Line: 28061 +// +// Define structure returned in response to IRP_MN_QUERY_BUS_INFORMATION by a +// PDO indicating the type of bus the device exists on. +// + +typedef struct _PNP_BUS_INFORMATION { + GUID BusTypeGuid; + INTERFACE_TYPE LegacyBusType; + ULONG BusNumber; +} PNP_BUS_INFORMATION, *PPNP_BUS_INFORMATION; + + //copied from line 5785 + // +// Macro definition for defining IOCTL and FSCTL function control codes. Note +// that function codes 0-2047 are reserved for Microsoft Corporation, and +// 2048-4095 are reserved for customers. +// + +#define CTL_CODE( DeviceType, Function, Method, Access ) ( \ + ((DeviceType) << 16) | ((Access) << 14) | ((Function) << 2) | (Method) \ +) + +//copied from line 5851 + +#define FILE_READ_DATA ( 0x0001 ) // file & pipe + +//copied from line 11243 + +// SLAyer: implement printf as NOP +#define KdPrint(x) + +/* ULONG */ +/* __cdecl */ +/* DbgPrint ( */ +/* _In_ PCHAR Format, */ +/* //_In_z_ _Printf_format_string_ PCSTR Format, */ +/* ... */ +/* ) */ +/* { */ +/* } */ +#define DbgPrint(x) 0L + +//copied from line 24848 +typedef +NTSTATUS +DRIVER_INITIALIZE ( + _In_ struct _DRIVER_OBJECT *DriverObject, + _In_ PUNICODE_STRING RegistryPath + ); + +typedef DRIVER_INITIALIZE *PDRIVER_INITIALIZE; + +// Copied from line 14200 +#ifndef FIELD_OFFSET +#define FIELD_OFFSET(type, field) ((ULONG)&(((type *)0)->field)) +#endif + +typedef unsigned __int64 ULONG64, *PULONG64; + +// line 16380 +#define KI_USER_SHARED_DATA 0xFFFFF78000000000UI64 +#define SharedSystemTime (KI_USER_SHARED_DATA + 0x14) +#define KeQuerySystemTime(CurrentCount) \ + + +// line 29191 +/* PS #637 --KK */ +NTSTATUS +IoWMIWriteEvent( + IN PVOID WnodeEventItem + ) +{ + NTSTATUS status; + return status; +} +// +// line 30100 +typedef +// _Function_class_(GET_SET_DEVICE_DATA) +// _IRQL_requires_same_ +ULONG GET_SET_DEVICE_DATA ( + // _Inout_opt_ + PVOID Context, + // _In_ + ULONG DataType, + // _Inout_updates_bytes_(Length) + PVOID Buffer, + // _In_ + ULONG Offset, + // _In_ + ULONG Length + ); +typedef GET_SET_DEVICE_DATA *PGET_SET_DEVICE_DATA; + +typedef struct _BUS_INTERFACE_STANDARD { + /* generic interface header */ + USHORT Size; + // USHORT Version; + PVOID Context; + // PINTERFACE_REFERENCE InterfaceReference; + // PINTERFACE_DEREFERENCE InterfaceDereference; + /* standard bus interfaces */ + // PTRANSLATE_BUS_ADDRESS TranslateBusAddress; + // PGET_DMA_ADAPTER GetDmaAdapter; + PGET_SET_DEVICE_DATA SetBusData; + PGET_SET_DEVICE_DATA GetBusData; +} BUS_INTERFACE_STANDARD, *PBUS_INTERFACE_STANDARD; + +// Copied from line 30049 +typedef enum { + DevicePropertyDeviceDescription = 0x0 /* | __string_type */ , +/* + DevicePropertyHardwareID = 0x1 | __multiString_type, + DevicePropertyCompatibleIDs = 0x2 | __multiString_type, + DevicePropertyBootConfiguration = 0x3, + DevicePropertyBootConfigurationTranslated = 0x4, + DevicePropertyClassName = 0x5 | __string_type, + DevicePropertyClassGuid = 0x6 | __string_type, + DevicePropertyDriverKeyName = 0x7 | __string_type, + DevicePropertyManufacturer = 0x8 | __string_type, +*/ + DevicePropertyFriendlyName = 0x9 /* | __string_type*/, +/* + DevicePropertyLocationInformation = 0xa | __string_type, + DevicePropertyPhysicalDeviceObjectName = 0xb | __string_type, + DevicePropertyBusTypeGuid = 0xc | __guid_type, + DevicePropertyLegacyBusType = 0xd, + DevicePropertyBusNumber = 0xe, + DevicePropertyEnumeratorName = 0xf | __string_type, + DevicePropertyAddress = 0x10, +*/ + DevicePropertyUINumber = 0x11, +/* + DevicePropertyInstallState = 0x12, + DevicePropertyRemovalPolicy = 0x13, + DevicePropertyResourceRequirements = 0x14, + DevicePropertyAllocatedResources = 0x15, + DevicePropertyContainerID = 0x16 | __string_type +*/ +} DEVICE_REGISTRY_PROPERTY; + +// copied from line 29298 +typedef +//_Function_class_(WMI_NOTIFICATION_CALLBACK) +//_IRQL_requires_same_ +VOID FWMI_NOTIFICATION_CALLBACK ( + PVOID Wnode, + PVOID Context + ); +typedef FWMI_NOTIFICATION_CALLBACK *WMI_NOTIFICATION_CALLBACK; + +//copied from line 30667 +#define PLUGPLAY_REGKEY_DEVICE 1 + +// Copied from line 30778 +typedef +//_Function_class_(DRIVER_NOTIFICATION_CALLBACK_ROUTINE) +//_IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +DRIVER_NOTIFICATION_CALLBACK_ROUTINE ( + /*_In_*/ PVOID NotificationStructure, + /*_Inout_opt_*/ PVOID Context +); +typedef DRIVER_NOTIFICATION_CALLBACK_ROUTINE + *PDRIVER_NOTIFICATION_CALLBACK_ROUTINE; + +// Copied from line 30764 +typedef enum _IO_NOTIFICATION_EVENT_CATEGORY { + EventCategoryReserved, + EventCategoryHardwareProfileChange, + EventCategoryDeviceInterfaceChange, + EventCategoryTargetDeviceChange +} IO_NOTIFICATION_EVENT_CATEGORY; + +DECLARE_HANDLE(PDRIVER_OBJECT); // SI: defined in ddk/wdm.h + +// SLAyer: incomplete +/* Reimplementing this myself, as there seems to be no WDF implementation + * to be found. THIS IS PROBABLY INCORRECT! --KK #PS636 + */ +NTSTATUS +IoRegisterPlugPlayNotification( + /*_In_*/ IO_NOTIFICATION_EVENT_CATEGORY EventCategory, + /*_In_*/ ULONG EventCategoryFlags, + /*_In_opt_*/ PVOID EventCategoryData, + /*_In_*/ PDRIVER_OBJECT DriverObject, + /*_In_*/ PDRIVER_NOTIFICATION_CALLBACK_ROUTINE CallbackRoutine, + /*_Inout_opt_ __drv_aliasesMem*/ PVOID Context, + /*_Outptr_result_nullonfailure_*/ + /*_At_(*NotificationEntry, + _When_(return==0, __drv_allocatesMem(Mem)))*/ + PVOID *NotificationEntry + ) +{ + SLAyer_nondetT(NTSTATUS); +} + +#define PNPNOTIFY_DEVICE_INTERFACE_INCLUDE_EXISTING_INTERFACES 0x00000001 + +// copied from line 30916 +typedef struct _DEVICE_INTERFACE_CHANGE_NOTIFICATION { + USHORT Version; + USHORT Size; + GUID Event; + // + // Event-specific data + // + GUID InterfaceClassGuid; + PUNICODE_STRING SymbolicLinkName; +} DEVICE_INTERFACE_CHANGE_NOTIFICATION, *PDEVICE_INTERFACE_CHANGE_NOTIFICATION; + +// line 31462 +typedef struct _SCATTER_GATHER_LIST { + ULONG NumberOfElements; + // ULONG_PTR Reserved; + // SCATTER_GATHER_ELEMENT Elements[]; +} SCATTER_GATHER_LIST, *PSCATTER_GATHER_LIST; + +// line 32972 +#define PCI_TYPE0_ADDRESSES 6 +#define PCI_TYPE1_ADDRESSES 2 +#define PCI_TYPE2_ADDRESSES 5 + +// Patch: commenting most fields out +typedef struct _PCI_COMMON_HEADER { + USHORT VendorID; // (ro) + USHORT DeviceID; // (ro) + USHORT Command; // Device control + /* + USHORT Status; + */ + UCHAR RevisionID; // (ro) + /* + UCHAR ProgIf; // (ro) + UCHAR SubClass; // (ro) + UCHAR BaseClass; // (ro) + UCHAR CacheLineSize; // (ro+) + UCHAR LatencyTimer; // (ro+) + UCHAR HeaderType; // (ro) + UCHAR BIST; // Built in self test + */ + union { + struct _PCI_HEADER_TYPE_0 { + /* + ULONG BaseAddresses[PCI_TYPE0_ADDRESSES]; + ULONG CIS; + */ + USHORT SubVendorID; + USHORT SubSystemID; + /* + ULONG ROMBaseAddress; + UCHAR CapabilitiesPtr; + UCHAR Reserved1[3]; + ULONG Reserved2; + UCHAR InterruptLine; // + UCHAR InterruptPin; // (ro) + UCHAR MinimumGrant; // (ro) + UCHAR MaximumLatency; // (ro) + */ + } type0; + /* + // PCI to PCI Bridge + struct _PCI_HEADER_TYPE_1 { + ULONG BaseAddresses[PCI_TYPE1_ADDRESSES]; + UCHAR PrimaryBus; + UCHAR SecondaryBus; + UCHAR SubordinateBus; + UCHAR SecondaryLatency; + UCHAR IOBase; + UCHAR IOLimit; + USHORT SecondaryStatus; + USHORT MemoryBase; + USHORT MemoryLimit; + USHORT PrefetchBase; + USHORT PrefetchLimit; + ULONG PrefetchBaseUpper32; + ULONG PrefetchLimitUpper32; + USHORT IOBaseUpper16; + USHORT IOLimitUpper16; + UCHAR CapabilitiesPtr; + UCHAR Reserved1[3]; + ULONG ROMBaseAddress; + UCHAR InterruptLine; + UCHAR InterruptPin; + USHORT BridgeControl; + } type1; + // PCI to CARDBUS Bridge + struct _PCI_HEADER_TYPE_2 { + ULONG SocketRegistersBaseAddress; + UCHAR CapabilitiesPtr; + UCHAR Reserved; + USHORT SecondaryStatus; + UCHAR PrimaryBus; + UCHAR SecondaryBus; + UCHAR SubordinateBus; + UCHAR SecondaryLatency; + struct { + ULONG Base; + ULONG Limit; + } Range[PCI_TYPE2_ADDRESSES-1]; + UCHAR InterruptLine; + UCHAR InterruptPin; + USHORT BridgeControl; + } type2; + */ + } u; +} PCI_COMMON_HEADER, *PPCI_COMMON_HEADER; + +// line 33062 + /* Patch. The code in wdm and miniport uses some weird syntax; I think + * that this struct `inherits' some fields from PCI_COMMON_HEADER. In + * particular, VendorID is udes in pci_drv/HW/nic_init.c. + */ +typedef struct _PCI_COMMON_CONFIG { + USHORT VendorID; // (ro) + USHORT DeviceID; // (ro) + USHORT Command; // Device control + /* + USHORT Status; + */ + UCHAR RevisionID; // (ro) + /* + UCHAR ProgIf; // (ro) + UCHAR SubClass; // (ro) + UCHAR BaseClass; // (ro) + UCHAR CacheLineSize; // (ro+) + UCHAR LatencyTimer; // (ro+) + UCHAR HeaderType; // (ro) + UCHAR BIST; // Built in self test + */ + union { + struct _PCI_HEADER_TYPE_0 type0; + /* + // PCI to PCI Bridge + struct _PCI_HEADER_TYPE_1 type1; + // PCI to CARDBUS Bridge + struct _PCI_HEADER_TYPE_2 type2; + */ + } u; + /* This is an additional field that is defined only in + * PCI_COMMON_CONFIG and not in PCI_COMMON_HEADER. + */ + UCHAR DeviceSpecific[192]; +} PCI_COMMON_CONFIG, *PPCI_COMMON_CONFIG; + +// line 33108 +#define PCI_ENABLE_WRITE_AND_INVALIDATE 0x0010 + +/****************************************************************************** + * File: wdf.h. + ******************************************************************************/ +#define WDF_EXTERN_C + +/****************************************************************************** + * File: wdftypes.h. + ******************************************************************************/ + +typedef enum _WDF_TRI_STATE { + WdfFalse = FALSE, + WdfTrue = TRUE, + WdfUseDefault = 2, +} WDF_TRI_STATE, *PWDF_TRI_STATE; + +typedef PVOID WDFCONTEXT; + +DECLARE_HANDLE(WDFDMAENABLER); +DECLARE_HANDLE(WDFDMATRANSACTION); +DECLARE_HANDLE(WDFCOMMONBUFFER); +DECLARE_HANDLE(WDFLOOKASIDE); + +// Copied from WDK/inc/kmdf/1.9/wdftypes.h, line 77. +// +// Forward declare structures needed later header files +// +// Patch: added underscore to WDFDEVICE_INIT. + +typedef struct _WDF_OBJECT_ATTRIBUTES *PWDF_OBJECT_ATTRIBUTES; + +#define WDF_NO_OBJECT_ATTRIBUTES (NULL) +#define WDF_NO_EVENT_CALLBACK (NULL) +#define WDF_NO_HANDLE (NULL) +#define WDF_NO_CONTEXT (NULL) +#define WDF_NO_SEND_OPTIONS (NULL) + +// Patch: Never even declared in wd*.h, let alone declared as HANDLE. +DECLARE_HANDLE(PWDF_DRIVER_GLOBALS); // SI: defined in wdfglobals.h +/* Moving this up, as a definition in wdm.h needs it --KK +DECLARE_HANDLE(PDRIVER_OBJECT); // SI: defined in ddk/wdm.h +*/ +DECLARE_HANDLE(WDFCMRESLIST); // SI: defined in wdftypes.h. + +// Copied from WDK/inc/kmdf/1.9/wdftypes.h, line 91. +// +// General Handle Type, should always be typeless +// +// SLAyer: provide an implementation of WDFOBJECT. +typedef enum _SLAyerObjTyp { + SLAyerWdfObject, + SLAyerWdfDevice, + SLAyerWdfDriver, + SLAyerWdfIoTarget, + SLAyerWdfQueue, + SLAyerWdfRequest, + SLAyerWdfTimer, + SLAyerWdfWmiInstance, +} SLAyerObjTyp ; + +typedef struct _SLAyer_WDFDEVICE_Ext { + struct _SLAyer_WDFOBJECT *Queue; // Device's Queue + struct _SLAyer_WDFOBJECT *WmiInstance1;// Device's WmiInstance #1 + struct _SLAyer_WDFOBJECT *WmiInstance2;// Device's WmiInstance #2 + struct _SLAyer_WDFOBJECT *WmiInstance3;// Device's WmiInstance #3 +} SLAyer_WDFDEVICE_Ext; + +typedef struct _SLAyer_WDFQUEUE_Ext { + struct _SLAyer_WDFOBJECT *Device; + void *InputBuffer; +} SLAyer_WDFQUEUE_Ext; + +typedef struct _SLAyer_WDFREQUEST_Ext { + int Buffer; // SI: un-used? Seems a duplicate of InputBuffer. + void *InputBuffer; +} SLAyer_WDFREQUEST_Ext; + +typedef struct _SLAyer_WDFWMIINSTANCE_Ext { + struct _SLAyer_WDFOBJECT *Device; +} SLAyer_WDFWMIINSTANCE_Ext; + +/* +SI: we should use Childx to store pointers to the children. For +instance, a SLAyerWdfDevice will have a queue, a couple of +wmiinstances. Then we won't need these SLAyer_WDFOBJECTs within +SLAyer_WDFx_Ext's. +*/ +typedef struct _SLAyer_WDFOBJECT { + // Framework Memory Management + unsigned int RefCount; + // Object Hierarchy + struct _SLAyer_WDFOBJECT *Parent; // SI: un-used right now? + struct _SLAyer_WDFOBJECT *Child1, *Child2; // Arbitrarily 2 children. + // Ctxt Space + void *Context; + // Type of WdfObject + SLAyerObjTyp typ; + // union TypData { + SLAyer_WDFDEVICE_Ext typDevice; + SLAyer_WDFQUEUE_Ext typQueue; // SI: typQueue.Device same as Parent? + SLAyer_WDFREQUEST_Ext typRequest; + SLAyer_WDFWMIINSTANCE_Ext typWmiInstance; + //} typData; +} SLAyer_WDFOBJECT; + +typedef SLAyer_WDFOBJECT *WDFOBJECT, **PWDFOBJECT; + +// +// core handles +// +typedef SLAyer_WDFOBJECT *WDFDRIVER; +typedef SLAyer_WDFOBJECT *WDFDEVICE; + +DECLARE_HANDLE( WDFWMIPROVIDER ); +typedef SLAyer_WDFOBJECT *WDFWMIINSTANCE; + +typedef SLAyer_WDFOBJECT *WDFQUEUE; + +//DECLARE_HANDLE( WDFREQUEST ); +// Patch: implementation of opaque type WDFREQUEST. +/* + typedef struct _WDFREQUEST { + int Buffer; // "32 bits should be enough for anybody" + void * InputBuffer; + } *WDFREQUEST; +*/ +typedef SLAyer_WDFOBJECT *WDFREQUEST; + +typedef struct _WDFBUFFER +{ + long X; + long Y; + long Z[4]; +} WDFBUFFER; + +DECLARE_HANDLE( WDFFILEOBJECT ); +DECLARE_HANDLE( WDFDPC ); +typedef SLAyer_WDFOBJECT *WDFTIMER; +DECLARE_HANDLE( WDFWORKITEM ); +DECLARE_HANDLE( WDFINTERRUPT ); + +DECLARE_HANDLE( WDFSPINLOCK ); +DECLARE_HANDLE( WDFWAITLOCK ); + +DECLARE_HANDLE( WDFMEMORY ); + +typedef SLAyer_WDFOBJECT *WDFIOTARGET; + +DECLARE_HANDLE( WDFKEY ); +DECLARE_HANDLE( WDFSTRING ); + +//copied from WDK/inc/kmdf/1.5/wdftypes.h, line 141 +DECLARE_HANDLE(WDFCOLLECTION); +DECLARE_HANDLE( WDFCHILDLIST ); + +// SI: reimplement this as a SLAyer_WDFOBJECT sub-type. +/* typedef struct _WDFBUFFER */ +/* { */ +/* long X; */ +/* long Y; */ +/* long Z[4]; */ +/* } WDFBUFFER; */ + +/****************************************************************************** + * File: wdfobject.h. + ******************************************************************************/ + +// Copied from c:/slam/WDK/inc/wdf/kmdf/1.9/wdfobject.h, line 27. +// +// Specifies the highest IRQL level allowed on callbacks +// to the device driver. +// +typedef enum _WDF_EXECUTION_LEVEL { + WdfExecutionLevelInvalid = 0x00, + WdfExecutionLevelInheritFromParent, + WdfExecutionLevelPassive, + WdfExecutionLevelDispatch, +} WDF_EXECUTION_LEVEL; + +// +// Specifies the concurrency of callbacks to the device driver +// +typedef enum _WDF_SYNCHRONIZATION_SCOPE { + WdfSynchronizationScopeInvalid = 0x00, + WdfSynchronizationScopeInheritFromParent, + WdfSynchronizationScopeDevice, + WdfSynchronizationScopeQueue, + WdfSynchronizationScopeNone, +} WDF_SYNCHRONIZATION_SCOPE; + +typedef +__drv_functionClass(EVT_WDF_OBJECT_CONTEXT_CLEANUP) +__drv_sameIRQL +__drv_maxIRQL(DISPATCH_LEVEL) +VOID +EVT_WDF_OBJECT_CONTEXT_CLEANUP( + __in + WDFOBJECT Object + ); + +typedef EVT_WDF_OBJECT_CONTEXT_CLEANUP *PFN_WDF_OBJECT_CONTEXT_CLEANUP; + +typedef +__drv_functionClass(EVT_WDF_OBJECT_CONTEXT_DESTROY) +__drv_sameIRQL +__drv_maxIRQL(DISPATCH_LEVEL) +VOID +EVT_WDF_OBJECT_CONTEXT_DESTROY( + __in + WDFOBJECT Object + ); + +typedef EVT_WDF_OBJECT_CONTEXT_DESTROY *PFN_WDF_OBJECT_CONTEXT_DESTROY; + +typedef const struct _WDF_OBJECT_CONTEXT_TYPE_INFO *PCWDF_OBJECT_CONTEXT_TYPE_INFO; + +// SLAyer: context per object +typedef void* MK_CONTEXT() ; +typedef MK_CONTEXT *PFN_MK_CONTEXT; +#define SLAyer_MK_CONTEXT_NAME(_contexttype) SLAyer_mk_ ## _contexttype + +typedef struct _WDF_OBJECT_ATTRIBUTES { + ULONG Size; + PFN_WDF_OBJECT_CONTEXT_CLEANUP EvtCleanupCallback; + PFN_WDF_OBJECT_CONTEXT_DESTROY EvtDestroyCallback; + WDF_EXECUTION_LEVEL ExecutionLevel; + WDF_SYNCHRONIZATION_SCOPE SynchronizationScope; + WDFOBJECT ParentObject; + size_t ContextSizeOverride; + PCWDF_OBJECT_CONTEXT_TYPE_INFO ContextTypeInfo; + // SLAyer: context per object + PFN_MK_CONTEXT MkContext; +} WDF_OBJECT_ATTRIBUTES, *PWDF_OBJECT_ATTRIBUTES; + +VOID +FORCEINLINE +WDF_OBJECT_ATTRIBUTES_INIT( + __out PWDF_OBJECT_ATTRIBUTES Attributes + ) +{ + /* Patch: */ + WDF_EXECUTION_LEVEL ParentExecutionLevel; + WDF_SYNCHRONIZATION_SCOPE ParentSynchronizationScope; + Attributes->ExecutionLevel=/*WdfExecutionLevelInheritFromParent*/ParentExecutionLevel; + Attributes->SynchronizationScope=/*WdfSynchronizationScopeInheritFromParent*/ParentSynchronizationScope; +} + +// SLAyer: context per object +#define SLAyer_WDF_OBJECT_ATTRIBUTES_SET_MK_CONTEXT(_attributes, _contexttype) \ + (_attributes)->MkContext = &(SLAyer_MK_CONTEXT_NAME(_contexttype)) + +// SLAyer: context per object. Store into ->MkContext too? +//#define WDF_OBJECT_ATTRIBUTES_SET_CONTEXT_TYPE(_attributes, _contexttype) \ +// (_attributes)->ContextTypeInfo = WDF_GET_CONTEXT_TYPE_INFO(_contexttype)->UniqueType; + +#define WDF_OBJECT_ATTRIBUTES_SET_CONTEXT_TYPE(_attributes, _contexttype) \ + SLAyer_WDF_OBJECT_ATTRIBUTES_SET_MK_CONTEXT(_attributes, _contexttype) + +// +// VOID +// FORCEINLINE +// WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE( +// PWDF_OBJECT_ATTRIBUTES Attributes, +// +// ) +// +// NOTE: Do not put a ; at the end of the last line. This will require the +// caller to specify a ; after the call. +// +// SLAyer: context per object +#define WDF_OBJECT_ATTRIBUTES_INIT_CONTEXT_TYPE(_attributes, _contexttype) \ + WDF_OBJECT_ATTRIBUTES_INIT(_attributes); \ + WDF_OBJECT_ATTRIBUTES_SET_CONTEXT_TYPE(_attributes, _contexttype); + +typedef +PCWDF_OBJECT_CONTEXT_TYPE_INFO +(__cdecl *PFN_GET_UNIQUE_CONTEXT_TYPE)( + VOID + ); + +// +// Since C does not have strong type checking we must invent our own +// +typedef struct _WDF_OBJECT_CONTEXT_TYPE_INFO { + // + // The size of this structure in bytes + // + ULONG Size; + + // + // String representation of the context's type name, i.e. "DEVICE_CONTEXT" + // + PCHAR ContextName; + + // + // The size of the context in bytes. This will be the size of the context + // associated with the handle unless + // WDF_OBJECT_ATTRIBUTES::ContextSizeOverride is specified. + // + size_t ContextSize; + + // + // If NULL, this structure is the unique type identifier for the context + // type. If != NULL, the UniqueType pointer value is the unique type id + // for the context type. + // + PCWDF_OBJECT_CONTEXT_TYPE_INFO UniqueType; + + // + // Function pointer to retrieve the context type information structure + // pointer from the provider of the context type. This function is invoked + // by the client driver's entry point by the KMDF stub after all class + // drivers are loaded and before DriverEntry is invoked. + // + PFN_GET_UNIQUE_CONTEXT_TYPE EvtDriverGetUniqueContextType; + +} WDF_OBJECT_CONTEXT_TYPE_INFO, *PWDF_OBJECT_CONTEXT_TYPE_INFO; + +// +// Converts a type name a unique name in which we can retrieve type specific +// information. +// +#define WDF_TYPE_NAME_TO_TYPE_INFO(_contexttype) \ + _WDF_ ## _contexttype ## _TYPE_INFO + +// +// Converts a type name a unique name to the structure which will initialize +// it through an external component. +// +#define WDF_TYPE_NAME_TO_EXTERNAL_INIT(_contexttype) \ + _WDF_ ## _contexttype ## _EXTERNAL_INIT + +#define WDF_TYPE_NAME_TO_EXTERNAL_INIT_FUNCTION(_contexttype) \ + _contexttype ## _EXTERNAL_INIT_FUNCTION + +// +// Returns an address to the type information representing this typename +// +#define WDF_GET_CONTEXT_TYPE_INFO(_contexttype) \ + (&WDF_TYPE_NAME_TO_TYPE_INFO(_contexttype)) + +// +// Used to help generate our own usable pointer to the type typedef. For instance, +// a call as WDF_TYPE_NAME_POINTER_TYPE(DEVICE_CONTEXT) would generate: +// +// WDF_POINTER_TYPE_DEVICE_CONTEXT +// +// which would be the equivalent of DEVICE_CONTEXT* +// +#define WDF_TYPE_NAME_POINTER_TYPE(_contexttype) \ + WDF_POINTER_TYPE_ ## _contexttype + +// +// Declares a typename so that in can be associated with a handle. This will +// use the type's name with a _ prepended as the "friendly name" (which results +// in the autogenerated casting function being named WdfObjectGet_, ie +// WdfObjectGet_DEVICE_CONTEXT. See WDF_DECLARE_CONTEXT_TYPE_WITH_NAME for +// more details on what is generated. +// +#define WDF_DECLARE_CONTEXT_TYPE(_contexttype) \ + WDF_DECLARE_CONTEXT_TYPE_WITH_NAME(_contexttype, WdfObjectGet_ ## _contexttype) + +// +// WDF_DECLARE_CONTEXT_TYPE_WITH_NAME performs the following 3 tasks +// +// 1) declare a typedef for the context type so that its pointer type can be +// referred to later +// 2) declare and initialize global structure that represents the type +// information for this +// context type +// 3) declare and implement a function named _castingfunction +// which does the proper type conversion. +// +// WDF_DECLARE_TYPE_AND_GLOBALS implements 1 & 2 +// WDF_DECLARE_CASTING_FUNCTION implements 3 +// +// For instance, the invocation of +// WDF_DECLARE_CONTEXT_TYPE_WITH_NAME(DEVICE_CONTEXT, WdfDeviceGetContext) +// would result in the following being generated: +// +// typedef DEVICE_CONTEXT* WDF_POINTER_TYPE_DEVICE_CONTEXT; +// +// extern const __declspec(selectany) WDF_OBJECT_CONTEXT_TYPE_INFO _WDF_DEVICE_CONTEXT_TYPE_INFO = +// { +// sizeof(WDF_OBJECT_CONTEXT_TYPE_INFO), +// "DEVICE_CONTEXT", +// sizeof(DEVICE_CONTEXT), +// }; +// +// WDF_POINTER_TYPE_DEVICE_CONTEXT +// WdfDeviceGetContext( +// WDFOBJECT Handle +// ) +// { +// return (WDF_POINTER_TYPE_DEVICE_CONTEXT) +// WdfObjectGetTypedContextWorker( +// Handle, +// (&_WDF_DEVICE_CONTEXT_TYPE_INFO)->UniqueType +// ); +// } +// +#define WDF_TYPE_INIT_BASE_SECTION_NAME ".kmdftypeinit" +#define WDF_TYPE_INIT_SECTION_NAME ".kmdftypeinit$b" + +// +// .data is the default section that global data would be placed into. We +// cannot just use ".data" in __declspec(allocate()) without first declaring +// it in a #pragma section() even though it is a default section name. +// +#ifndef WDF_TYPE_DEFAULT_SECTION_NAME +#define WDF_TYPE_DEFAULT_SECTION_NAME ".data" +#endif // WDF_TYPE_DEFAULT_SECTION_NAME + +#pragma section(WDF_TYPE_INIT_SECTION_NAME, read, write) +#pragma section(WDF_TYPE_DEFAULT_SECTION_NAME) + +#define WDF_DECLARE_TYPE_AND_GLOBALS(_contexttype, _UniqueType, _GetUniqueType, _section)\ + \ +typedef _contexttype* WDF_TYPE_NAME_POINTER_TYPE(_contexttype); \ + \ +WDF_EXTERN_C __declspec(allocate( _section )) __declspec(selectany) extern const WDF_OBJECT_CONTEXT_TYPE_INFO WDF_TYPE_NAME_TO_TYPE_INFO(_contexttype) = \ +{ \ + sizeof(WDF_OBJECT_CONTEXT_TYPE_INFO), \ + #_contexttype, \ + sizeof(_contexttype), \ + _UniqueType, \ + _GetUniqueType, \ +}; \ + +#define WDF_DECLARE_CASTING_FUNCTION(_contexttype, _castingfunction) \ + \ +__drv_aliasesMem \ +WDF_EXTERN_C \ +WDF_TYPE_NAME_POINTER_TYPE(_contexttype) \ +FORCEINLINE \ +_castingfunction( \ + __in WDFOBJECT Handle \ + ) \ +{ \ + return (WDF_TYPE_NAME_POINTER_TYPE(_contexttype)) \ + WdfObjectGetTypedContextWorker( \ + Handle, \ + WDF_GET_CONTEXT_TYPE_INFO(_contexttype)->UniqueType \ + ); \ +} + +#define WDF_DECLARE_CONTEXT_TYPE_WITH_NAME(_contexttype, _castingfunction) \ + \ +WDF_DECLARE_TYPE_AND_GLOBALS( \ + _contexttype, \ + WDF_GET_CONTEXT_TYPE_INFO(_contexttype), \ + NULL, \ + WDF_TYPE_DEFAULT_SECTION_NAME) \ + \ +WDF_DECLARE_CASTING_FUNCTION(_contexttype, _castingfunction) + +/* +SLAyer: Patch +SLayer version of WDF_DECLARE_CONTEXT_TYPE_WITH_NAME. We declare two +functions here: SLAyer_mk_ mallocs a context; _castingfunction +returns the object's context. Even though SLayer_mk_ returns a void*, +we need the object to remain a _contexttype. That's also the reason +why _castingfunction takes a SL_WDFOBJECT, rather than a void*. +(We also immediately take the address of the SLAyer_mk_ function, otherwise +it might get optimized away.) +*/ +#ifdef WDF_DECLARE_CONTEXT_TYPE_WITH_NAME +#undef WDF_DECLARE_CONTEXT_TYPE_WITH_NAME +#endif +#define WDF_DECLARE_CONTEXT_TYPE_WITH_NAME(_contexttype, _castingfunction) \ + \ + void* SLAyer_mk_##_contexttype() \ + { \ + _contexttype * ctxt_obj; \ + ctxt_obj = (_contexttype *)_SLAyer_malloc(sizeof( _contexttype )); \ + return ctxt_obj ; \ + } \ + \ + PFN_MK_CONTEXT SLAyer_use_##_contexttype = &SLAyer_mk_##_contexttype; \ + \ + _contexttype * _castingfunction(SLAyer_WDFOBJECT * Handle) \ + { \ + return (Handle->Context); \ + } + +/* These two are declared in func/featured/toasterMof.h +DECLARE_HANDLE(PToasterDeviceInformation); +DECLARE_HANDLE(PToasterControl); +*/ + +// +// WDF_DECLARE_SHARED_CONTEXT_TYPE_WITH_NAME is the same as +// WDF_DECLARE_CONTEXT_TYPE_WITH_NAME with respect to the types and structures +// that are created and initialized. The casting function is different in that +// it passes the UniqueType to WdfObjectGetTypedContextWorker() instead of the +// global type structure created. It also creates a structure which will contain +// an initialization function which will be invoked before DriverEntry() is +// called. +// +// It is the responsibilty of the component exporting the unique type to define +// and implement the function which will return the unique type. The format of +// the define is: +// +// #define _contexttype ## _EXTERNAL_INIT_FUNCTION +// +// (e.g. #define DEVICE_CONTEXT_EXTERNALINIT_FUNCTION DeviceContextInit() +// for a type of DEVICE_CONTEXT) +// +#define WDF_DECLARE_SHARED_CONTEXT_TYPE_WITH_NAME(_contexttype, _castingfunction) \ + \ +WDF_DECLARE_TYPE_AND_GLOBALS( \ + _contexttype, \ + NULL, \ + WDF_TYPE_NAME_TO_EXTERNAL_INIT_FUNCTION(_contexttype), \ + WDF_TYPE_INIT_SECTION_NAME) \ + \ +WDF_DECLARE_CASTING_FUNCTION(_contexttype, _castingfunction) + +// +// WDF_DECLARE_SHARED_CONTEXT_TYPE_WITH_NAME is the same as +// WDF_DECLARE_CONTEXT_TYPE_WITH_NAME with respect to the types and structures +// that are created and initialized. The casting function is different in that +// it passes the UniqueType to WdfObjectGetTypedContextWorker() instead of the +// global type structure created. It also creates a structure which will contain +// an initialization function which will be invoked before DriverEntry() is +// called. +// +// It is the responsibilty of the component exporting the unique type to define +// and implement the function which will return the unique type. The format of +// the define is: +// +// #define _contexttype ## _EXTERNAL_INIT_FUNCTION +// +// (e.g. #define DEVICE_CONTEXT_EXTERNALINIT_FUNCTION DeviceContextInit() +// for a type of DEVICE_CONTEXT) +// +#define WDF_DECLARE_SHARED_CONTEXT_TYPE_WITH_NAME(_contexttype, _castingfunction) \ + \ +WDF_DECLARE_TYPE_AND_GLOBALS( \ + _contexttype, \ + NULL, \ + WDF_TYPE_NAME_TO_EXTERNAL_INIT_FUNCTION(_contexttype), \ + WDF_TYPE_INIT_SECTION_NAME) \ + \ +WDF_DECLARE_CASTING_FUNCTION(_contexttype, _castingfunction) + +// +// Generic conversion macro from handle to type. This should be used if the +// autogenerated conversion function does not suite the programmers calling style. +// +// The type parameter should be name of the type (e.g. DEVICE_CONTEXT), not the +// name of the pointer to the type (PDEVICE_CONTEXT). +// +// Example call: +// +// WDFDEVICE device; +// PDEVICE_CONTEXT pContext; +// +// pContext = WdfObjectGetTypedContext(device, DEVICE_CONTEXT); +// +// +#define WdfObjectGetTypedContext(handle, type) \ +(type*) \ +WdfObjectGetTypedContextWorker( \ + (WDFOBJECT) handle, \ + WDF_GET_CONTEXT_TYPE_INFO(type)->UniqueType \ + ) + +// +// WDF Function: WdfObjectGetTypedContextWorker +// +/* typedef */ +/* WDFAPI */ +/* PVOID */ +/* (FASTCALL *PFN_WDFOBJECTGETTYPEDCONTEXTWORKER)( */ +/* __in */ +/* PWDF_DRIVER_GLOBALS DriverGlobals, */ +/* __in */ +/* WDFOBJECT Handle, */ +/* __in */ +/* PCWDF_OBJECT_CONTEXT_TYPE_INFO TypeInfo */ +/* ); */ + +PVOID /* FORCEINLINE */ WdfObjectGetTypedContextWorker( +/* __in */ + WDFOBJECT Handle, +/* __in */ + PCWDF_OBJECT_CONTEXT_TYPE_INFO TypeInfo + ) +{ + /* return ((PFN_WDFOBJECTGETTYPEDCONTEXTWORKER) WdfFunctions[WdfObjectGetTypedContextWorkerTableIndex])(WdfDriverGlobals, Handle, TypeInfo); */ + // Patch: provide an implementation of GetTypedContextWorker. + PVOID ctxt = NULL; + // Compare TypeInfo->ContextName to context->id to get right context. + // ToDo: Should do some string->int hashing here instead. + // if (*(Handle->context0.id) == *(TypeInfo->ContextName)) ctxt = Handle->context0.data; + return ctxt; +} + + +VOID +WdfObjectDelete(WDFOBJECT obj) +{ + // SI: Normally, we shouldn't be free-ing Device objects: + // http://msdn.microsoft.com/en-us/library/windows/hardware/ff548734(v=vs.85).aspx + if (obj == SL_Device_one) { + return; + } + + if (obj == SL_Device_two) { + return; + } + + if (NULL != obj->Context) { free(obj->Context); } + free(obj); + return; +} + +/****************************************************************************** + * File: wdfsync.h + ******************************************************************************/ + +VOID WdfSpinLockAcquire(WDFSPINLOCK l) {} +VOID WdfSpinLockRelease(WDFSPINLOCK l) {} + +NTSTATUS WdfWaitLockCreate(PWDF_OBJECT_ATTRIBUTES LockAttibutes, WDFWAITLOCK *Lock) +{ + SLAyer_nondetT(NTSTATUS); +} + +VOID WdfWaitLockAcquire(WDFWAITLOCK l, PLONGLONG Timeout) {} +VOID WdfWaitLockRelease(WDFWAITLOCK l) {} + +/****************************************************************************** + * File: wdfdriver.h. + ******************************************************************************/ + +// Copied from c:/slam/WDK/inc/wdf/kmdf/1.9/wdfdriver.h, line 45. +typedef +/* __ drv_functionClass(EVT_WDF_DRIVER_DEVICE_ADD) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DRIVER_DEVICE_ADD( +/* __in */ + WDFDRIVER Driver, +/* __inout */ + PWDFDEVICE_INIT DeviceInit + ); +typedef EVT_WDF_DRIVER_DEVICE_ADD *PFN_WDF_DRIVER_DEVICE_ADD; + +typedef +/* __drv_functionClass(EVT_WDF_DRIVER_UNLOAD) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +VOID +EVT_WDF_DRIVER_UNLOAD( +/* __in */ + WDFDRIVER Driver + ); +typedef EVT_WDF_DRIVER_UNLOAD *PFN_WDF_DRIVER_UNLOAD; + +// Copied from c:/slam/WDK/inc/wdf/kmdf/1.9/wdfdriver.h, line 97. +typedef struct _WDF_DRIVER_CONFIG { + ULONG Size; + PFN_WDF_DRIVER_DEVICE_ADD EvtDriverDeviceAdd; + PFN_WDF_DRIVER_UNLOAD EvtDriverUnload; + ULONG DriverInitFlags; + ULONG DriverPoolTag; +} WDF_DRIVER_CONFIG, *PWDF_DRIVER_CONFIG; + +VOID +/* FORCEINLINE */ +WDF_DRIVER_CONFIG_INIT( + /* __out */ PWDF_DRIVER_CONFIG Config, + /* __in_opt */ PFN_WDF_DRIVER_DEVICE_ADD EvtDriverDeviceAdd + ) +{ +/* Patch: */ + /* RtlZeroMemory(Config, sizeof(WDF_DRIVER_CONFIG)); */ + Config->Size = 0; + Config->EvtDriverDeviceAdd = 0; + Config->EvtDriverUnload = 0; + Config->DriverInitFlags = 0; + Config->DriverPoolTag = 0; + + Config->Size = sizeof(WDF_DRIVER_CONFIG); + Config->EvtDriverDeviceAdd = EvtDriverDeviceAdd; +} + +// Copied from WDK/inc/wdf/kmdf/1.9/wdfdriver.h, line 201. +/* WDFAPI */ +NTSTATUS +WdfDriverCreate( + /* IN */ PDRIVER_OBJECT DriverObject, + /* IN */ PCUNICODE_STRING RegistryPath, + /* IN OPTIONAL */ PWDF_OBJECT_ATTRIBUTES DriverAttributes, + /* IN */ PWDF_DRIVER_CONFIG DriverConfig, + /* OUT OPTIONAL */ WDFDRIVER* Driver + ) +{ + WDFDRIVER driver; + driver = (WDFDRIVER)malloc(sizeof(SLAyer_WDFOBJECT)); + driver->Context = + (DriverAttributes == WDF_NO_OBJECT_ATTRIBUTES) ? NULL : + (*(DriverAttributes->MkContext))() ; + SL_Driver = driver; + if (WDF_NO_HANDLE != Driver) { *Driver = driver; } + return STATUS_SUCCESS; +} + +// line 255 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +PDRIVER_OBJECT +(*PFN_WDFDRIVERWDMGETDRIVEROBJECT)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFDRIVER Driver + ); + +//_IRQL_requires_max_(DISPATCH_LEVEL) +PDRIVER_OBJECT +FORCEINLINE +WdfDriverWdmGetDriverObject( + //_In_ + WDFDRIVER Driver + ) +{ + //return ((PFN_WDFDRIVERWDMGETDRIVEROBJECT) WdfFunctions[WdfDriverWdmGetDriverObjectTableIndex])(WdfDriverGlobals, Driver); + return NULL; +} + + /****************************************************************************** + * File: wdfchildlist.h + ******************************************************************************/ + //copied from line 32 + typedef enum _WDF_CHILD_LIST_RETRIEVE_DEVICE_STATUS { + WdfChildListRetrieveDeviceUndefined = 0, + WdfChildListRetrieveDeviceSuccess, + WdfChildListRetrieveDeviceNotYetCreated, + WdfChildListRetrieveDeviceNoSuchDevice, +} WDF_CHILD_LIST_RETRIEVE_DEVICE_STATUS, *PWDF_CHILD_LIST_RETRIEVE_DEVICE_STATUS; + + //copied from line 39 + + typedef enum _WDF_RETRIEVE_CHILD_FLAGS { + WdfRetrieveUnspecified = 0x0000, + WdfRetrievePresentChildren = 0x0001, + WdfRetrieveMissingChildren = 0x0002, + WdfRetrievePendingChildren = 0x0004, + WdfRetrieveAddedChildren = (WdfRetrievePresentChildren | WdfRetrievePendingChildren), + WdfRetrieveAllChildren = (WdfRetrievePresentChildren | WdfRetrievePendingChildren | WdfRetrieveMissingChildren), +} WDF_RETRIEVE_CHILD_FLAGS; + + //copied from line 50 + typedef struct _WDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER { + // + // Size in bytes of the entire description, including this header. + // + // Same value as WDF_CHILD_LIST_CONFIG::IdentificationDescriptionSize + // Used as a sanity check. + // + ULONG IdentificationDescriptionSize; +} WDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER, + *PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER; + + //copied from line 72 + + typedef struct _WDF_CHILD_ADDRESS_DESCRIPTION_HEADER { + // + // Size in bytes of the entire description, including this header. + // + // Same value as WDF_CHILD_LIST_CONFIG::AddressDescriptionSize + // Used as a sanity check. + // + ULONG AddressDescriptionSize; +} WDF_CHILD_ADDRESS_DESCRIPTION_HEADER, + *PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER; + + //copied from line 94 + +typedef +NTSTATUS +(*PFN_WDF_CHILD_LIST_CREATE_DEVICE)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription, + PWDFDEVICE_INIT ChildInit + ); + +typedef +VOID +(*PFN_WDF_CHILD_LIST_SCAN_FOR_CHILDREN)( + WDFCHILDLIST ChildList + ); + +typedef +VOID +(*PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COPY)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER SourceIdentificationDescription, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER DestinationIdentificationDescription + ); + +typedef +NTSTATUS +(*PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_DUPLICATE)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER SourceIdentificationDescription, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER DestinationIdentificationDescription + ); + +typedef +BOOLEAN +(*PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COMPARE)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER FirstIdentificationDescription, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER SecondIdentificationDescription + ); + +typedef +VOID +(*PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_CLEANUP)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription + ); + +typedef +VOID +(*PFN_WDF_CHILD_LIST_ADDRESS_DESCRIPTION_COPY)( + WDFCHILDLIST ChildList, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER SourceAddressDescription, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER DestinationAddressDescription + ); + +typedef +NTSTATUS +(*PFN_WDF_CHILD_LIST_ADDRESS_DESCRIPTION_DUPLICATE)( + WDFCHILDLIST ChildList, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER SourceAddressDescription, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER DestinationAddressDescription + ); + +typedef +VOID +(*PFN_WDF_CHILD_LIST_ADDRESS_DESCRIPTION_CLEANUP)( + WDFCHILDLIST ChildList, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER AddressDescription + ); + +typedef +BOOLEAN +(*PFN_WDF_CHILD_LIST_DEVICE_REENUMERATED)( + WDFCHILDLIST ChildList, + WDFDEVICE OldDevice, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER OldAddressDescription, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER NewAddressDescription + ); + //copied from wdf/kmdf/1.7/wdfchildlist.h, line 96 + +typedef +NTSTATUS +(EVT_WDF_CHILD_LIST_CREATE_DEVICE)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription, + PWDFDEVICE_INIT ChildInit + ); + +typedef EVT_WDF_CHILD_LIST_CREATE_DEVICE *PFN_WDF_CHILD_LIST_CREATE_DEVICE; + +typedef +NTSTATUS +(EVT_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_DUPLICATE)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER SourceIdentificationDescription, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER DestinationIdentificationDescription + ); + +typedef EVT_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_DUPLICATE *PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_DUPLICATE; + +typedef +BOOLEAN +(EVT_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COMPARE)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER FirstIdentificationDescription, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER SecondIdentificationDescription + ); + +typedef EVT_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COMPARE *PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COMPARE; + +typedef +VOID +(EVT_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_CLEANUP)( + WDFCHILDLIST ChildList, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription + ); + +typedef EVT_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_CLEANUP *PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_CLEANUP; + +typedef struct _WDF_CHILD_RETRIEVE_INFO { + ULONG Size; + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription; + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER AddressDescription; + WDF_CHILD_LIST_RETRIEVE_DEVICE_STATUS Status; + PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COMPARE EvtChildListIdentificationDescriptionCompare; +} WDF_CHILD_RETRIEVE_INFO, *PWDF_CHILD_RETRIEVE_INFO; + +typedef struct _WDF_CHILD_LIST_CONFIG { + ULONG Size; + ULONG IdentificationDescriptionSize; + ULONG AddressDescriptionSize; + PFN_WDF_CHILD_LIST_CREATE_DEVICE EvtChildListCreateDevice; + PFN_WDF_CHILD_LIST_SCAN_FOR_CHILDREN EvtChildListScanForChildren; + PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COPY EvtChildListIdentificationDescriptionCopy; + PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_DUPLICATE EvtChildListIdentificationDescriptionDuplicate; + PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_CLEANUP EvtChildListIdentificationDescriptionCleanup; + PFN_WDF_CHILD_LIST_IDENTIFICATION_DESCRIPTION_COMPARE EvtChildListIdentificationDescriptionCompare; + PFN_WDF_CHILD_LIST_ADDRESS_DESCRIPTION_COPY EvtChildListAddressDescriptionCopy; + PFN_WDF_CHILD_LIST_ADDRESS_DESCRIPTION_DUPLICATE EvtChildListAddressDescriptionDuplicate; + PFN_WDF_CHILD_LIST_ADDRESS_DESCRIPTION_CLEANUP EvtChildListAddressDescriptionCleanup; + PFN_WDF_CHILD_LIST_DEVICE_REENUMERATED EvtChildListDeviceReenumerated; +} WDF_CHILD_LIST_CONFIG, *PWDF_CHILD_LIST_CONFIG; + +//copied from line 321 + +typedef struct _WDF_CHILD_LIST_ITERATOR { + ULONG Size; + ULONG Flags; + PVOID Reserved[4]; +} WDF_CHILD_LIST_ITERATOR, *PWDF_CHILD_LIST_ITERATOR; + +// stubs +VOID WDF_CHILD_LIST_CONFIG_INIT(PWDF_CHILD_LIST_CONFIG Config, + ULONG IdDescSize, + PFN_WDF_CHILD_LIST_CREATE_DEVICE EvtChildListCreateDevice) +{ +} + +VOID WDF_CHILD_LIST_ITERATOR_INIT( + _Out_ PWDF_CHILD_LIST_ITERATOR Iterator, + _In_ ULONG Flags +) +{ +} + +NTSTATUS +WdfChildListAddOrUpdateChildDescriptionAsPresent(WDFDEVICE Device, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER AddressDescription) +{ + SLAyer_nondetT(NTSTATUS); +} + +// PS #640 Consider generalizing return values +NTSTATUS WdfChildListUpdateChildDescriptionAsMissing( + /*[in]*/ WDFCHILDLIST ChildList, + /*[in]*/ PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription +) +{ + SLAyer_nondetT(NTSTATUS); +} + + +NTSTATUS +WdfChildListAddOrUpdateChildDescriptionAsMissing(WDFDEVICE Device, + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription, + PWDF_CHILD_ADDRESS_DESCRIPTION_HEADER AddressDescription) +{ + SLAyer_nondetT(NTSTATUS); +} + +VOID WdfChildListBeginScan(WDFCHILDLIST List) {} +VOID WdfChildListEndScan(WDFCHILDLIST List) {} + +VOID WdfChildListBeginIteration( + /*[in]*/ WDFCHILDLIST ChildList, + /*[in]*/ PWDF_CHILD_LIST_ITERATOR Iterator +) +{ +} + +VOID WdfChildListEndIteration( + /*[in]*/ WDFCHILDLIST ChildList, + /*[in]*/ PWDF_CHILD_LIST_ITERATOR Iterator +) +{ +} + +VOID +WDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER_INIT( + PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription, + ULONG IdDescSize) +{ +} + +BOOLEAN WdfChildListRequestChildEject( + /*[in]*/ WDFCHILDLIST ChildList, + /*[in]*/ PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription +) +{ + SLAyer_nondetT(BOOLEAN); +} + +VOID WDF_CHILD_RETRIEVE_INFO_INIT( + _Out_ PWDF_CHILD_RETRIEVE_INFO Info, + _In_ PWDF_CHILD_IDENTIFICATION_DESCRIPTION_HEADER IdentificationDescription +) +{ +} + +NTSTATUS WdfChildListRetrieveNextDevice( + /*[in]*/ WDFCHILDLIST ChildList, + /*[in]*/ PWDF_CHILD_LIST_ITERATOR Iterator, + /*[out]*/ WDFDEVICE *Device, + /*[in, out]*/ PWDF_CHILD_RETRIEVE_INFO Info +) +{ + SLAyer_nondetT(NTSTATUS); +} + +WDFDEVICE WdfChildListGetDevice( +/* [in] */ WDFCHILDLIST ChildList +) +{ + return SL_Device_two; +} + + +/****************************************************************************** + * File: wdfdevice.h. + ****************************************************************************/ + +// wdf/kmdf/1.9/wdfdevice.h +// line 389 +typedef enum _WDF_FILEOBJECT_CLASS { + WdfFileObjectInvalid = 0, + WdfFileObjectNotRequired = 1, + WdfFileObjectWdfCanUseFsContext = 2, + WdfFileObjectWdfCanUseFsContext2 = 3, + WdfFileObjectWdfCannotUseFsContexts = 4, + WdfFileObjectCanBeOptional = 0x80000000, +} WDF_FILEOBJECT_CLASS, *PWDF_FILEOBJECT_CLASS; + +// Copied from /cygdrive/c/Program Files (x86)/Windows Kits/8.0/Include/wdf/kmdf/1.9/wdfdevice.h +// line 357 +typedef enum _WDF_POWER_POLICY_SX_WAKE_USER_CONTROL { + WakeUserControlInvalid = 0, + WakeDoNotAllowUserControl, + WakeAllowUserControl, +} WDF_POWER_POLICY_SX_WAKE_USER_CONTROL; + +// line 419 +typedef enum _WDF_DEVICE_IO_TYPE { + WdfDeviceIoUndefined = 0, + WdfDeviceIoNeither, + WdfDeviceIoBuffered, + WdfDeviceIoDirect, +} WDF_DEVICE_IO_TYPE, *PWDF_DEVICE_IO_TYPE; + +// line 435 +typedef enum _WDF_DEVICE_FAILED_ACTION { + WdfDeviceFailedUndefined = 0, + WdfDeviceFailedAttemptRestart, + WdfDeviceFailedNoRestart, +} WDF_DEVICE_FAILED_ACTION; + +// wdf/kmdf/1.9/wdfdevice.h +// line 465 +typedef +VOID +EVT_WDF_DEVICE_FILE_CREATE( + _In_ + WDFDEVICE Device, + _In_ + WDFREQUEST Request, + _In_ + WDFFILEOBJECT FileObject + ); + +typedef EVT_WDF_DEVICE_FILE_CREATE *PFN_WDF_DEVICE_FILE_CREATE; + +typedef +VOID +EVT_WDF_FILE_CLOSE( + _In_ + WDFFILEOBJECT FileObject + ); + +typedef EVT_WDF_FILE_CLOSE *PFN_WDF_FILE_CLOSE; + +typedef +VOID +EVT_WDF_FILE_CLEANUP( + _In_ + WDFFILEOBJECT FileObject + ); + +typedef EVT_WDF_FILE_CLEANUP *PFN_WDF_FILE_CLEANUP; + +// wdf/kmdf/1.9/wdfdevice.h +// line 465 +typedef struct _WDF_FILEOBJECT_CONFIG { + ULONG Size; + PFN_WDF_DEVICE_FILE_CREATE EvtDeviceFileCreate; + PFN_WDF_FILE_CLOSE EvtFileClose; + PFN_WDF_FILE_CLEANUP EvtFileCleanup; + WDF_TRI_STATE AutoForwardCleanupClose; + WDF_FILEOBJECT_CLASS FileObjectClass; + +} WDF_FILEOBJECT_CONFIG, *PWDF_FILEOBJECT_CONFIG; + +// wdf/kmdf/1.9/wdfdevice.h +// line 340 +// Copied from /cygdrive/c/Program Files (x86)/Windows Kits/8.0/Include/wdf/kmdf/1.9/wdfdevice.h +// line 1164 +typedef struct _WDF_DEVICE_POWER_POLICY_WAKE_SETTINGS { + ULONG Size; + DEVICE_POWER_STATE DxState; + WDF_POWER_POLICY_SX_WAKE_USER_CONTROL UserControlOfWakeSettings; + WDF_TRI_STATE Enabled; + BOOLEAN ArmForWakeIfChildrenAreArmedForWake; + BOOLEAN IndicateChildWakeOnParentWake; +} WDF_DEVICE_POWER_POLICY_WAKE_SETTINGS, *PWDF_DEVICE_POWER_POLICY_WAKE_SETTINGS; + +// Copied from c:/Program Files (x86)/Windows Kits/8.0/Include/wdf/kmdf/1.11/wdfdevice.h +// line 344 + +typedef enum _WDF_POWER_POLICY_S0_IDLE_CAPABILITIES { + IdleCapsInvalid = 0, + IdleCannotWakeFromS0, + IdleCanWakeFromS0, + IdleUsbSelectiveSuspend, +} WDF_POWER_POLICY_S0_IDLE_CAPABILITIES; + +// wdf/kmdf/1.9/wdfdevice.h +// line 347 +typedef enum _WDF_POWER_POLICY_S0_IDLE_USER_CONTROL { + IdleUserControlInvalid = 0, + IdleDoNotAllowUserControl, + IdleAllowUserControl, +} WDF_POWER_POLICY_S0_IDLE_USER_CONTROL; + +typedef enum _WDF_POWER_DEVICE_STATE { + WdfPowerDeviceInvalid = 0, + WdfPowerDeviceD0, + WdfPowerDeviceD1, + WdfPowerDeviceD2, + WdfPowerDeviceD3, + WdfPowerDeviceD3Final, + WdfPowerDevicePrepareForHibernation, + WdfPowerDeviceMaximum, +} WDF_POWER_DEVICE_STATE, *PWDF_POWER_DEVICE_STATE; + +// line 551 +VOID +FORCEINLINE +WDF_FILEOBJECT_CONFIG_INIT( + /*_Out_ */ PWDF_FILEOBJECT_CONFIG FileEventCallbacks, + /*_In_opt_*/ PFN_WDF_DEVICE_FILE_CREATE EvtDeviceFileCreate, + /*_In_opt_*/ PFN_WDF_FILE_CLOSE EvtFileClose, + /*_In_opt_*/ PFN_WDF_FILE_CLEANUP EvtFileCleanup + ) +{ + FileEventCallbacks->Size = sizeof(WDF_FILEOBJECT_CONFIG); + + FileEventCallbacks->EvtDeviceFileCreate = EvtDeviceFileCreate; + FileEventCallbacks->EvtFileClose = EvtFileClose; + FileEventCallbacks->EvtFileCleanup = EvtFileCleanup; + + FileEventCallbacks->FileObjectClass = WdfFileObjectWdfCannotUseFsContexts; + FileEventCallbacks->AutoForwardCleanupClose = WdfUseDefault; +} + +typedef enum _WDF_POWER_POLICY_IDLE_TIMEOUT_TYPE { + DriverManagedIdleTimeout = 0, + // SystemManagedIdleTimeout = 1, + // SystemManagedIdleTimeoutWithHint = 2 +} WDF_POWER_POLICY_IDLE_TIMEOUT_TYPE, *PWDF_POWER_POLICY_IDLE_TIMEOUT_TYPE; + +typedef enum _WDF_POWER_POLICY_IDLE_TIMEOUT_CONSTANTS { + IdleTimeoutDefaultConstant = 0, +} WDF_POWER_POLICY_IDLE_TIMEOUT_CONSTANTS; +#define IdleTimeoutDefaultValue ((ULONG) IdleTimeoutDefaultConstant) + +// line 752 +typedef +// _Function_class_(EVT_WDF_DEVICE_D0_ENTRY_POST_INTERRUPTS_ENABLED) +// _IRQL_requires_same_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_DEVICE_D0_ENTRY_POST_INTERRUPTS_ENABLED( + // _In_ + WDFDEVICE Device, + // _In_ + WDF_POWER_DEVICE_STATE PreviousState + ); + +typedef EVT_WDF_DEVICE_D0_ENTRY_POST_INTERRUPTS_ENABLED *PFN_WDF_DEVICE_D0_ENTRY_POST_INTERRUPTS_ENABLED; + +typedef +// _Function_class_(EVT_WDF_DEVICE_D0_EXIT_PRE_INTERRUPTS_DISABLED) +// _IRQL_requires_same_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_DEVICE_D0_EXIT_PRE_INTERRUPTS_DISABLED( + // _In_ + WDFDEVICE Device, + // _In_ + WDF_POWER_DEVICE_STATE TargetState + ); + +// line 866 +typedef +// _Function_class_(EVT_WDF_DEVICE_SELF_MANAGED_IO_SUSPEND) +// _IRQL_requires_same_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_DEVICE_SELF_MANAGED_IO_SUSPEND( + // _In_ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_SELF_MANAGED_IO_SUSPEND *PFN_WDF_DEVICE_SELF_MANAGED_IO_SUSPEND; + +typedef +// _Function_class_(EVT_WDF_DEVICE_SELF_MANAGED_IO_RESTART) +// _IRQL_requires_same_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_DEVICE_SELF_MANAGED_IO_RESTART( + // _In_ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_SELF_MANAGED_IO_RESTART *PFN_WDF_DEVICE_SELF_MANAGED_IO_RESTART; + +// Copied from c:/Program Files (x86)/Windows Kits/8.0/Include/wdf/kmdf/1.11/wdfdevice.h +// line 1083 +typedef struct _WDF_DEVICE_POWER_POLICY_IDLE_SETTINGS { + ULONG Size; + WDF_POWER_POLICY_S0_IDLE_CAPABILITIES IdleCaps; + DEVICE_POWER_STATE DxState; + ULONG IdleTimeout; + WDF_POWER_POLICY_S0_IDLE_USER_CONTROL UserControlOfIdleSettings; + WDF_TRI_STATE Enabled; + WDF_TRI_STATE PowerUpIdleDeviceOnSystemWake; + WDF_POWER_POLICY_IDLE_TIMEOUT_TYPE IdleTimeoutType; + WDF_TRI_STATE ExcludeD3Cold; +} WDF_DEVICE_POWER_POLICY_IDLE_SETTINGS, *PWDF_DEVICE_POWER_POLICY_IDLE_SETTINGS; + +VOID +FORCEINLINE +WDF_DEVICE_POWER_POLICY_IDLE_SETTINGS_INIT( + /*_Out_*/ PWDF_DEVICE_POWER_POLICY_IDLE_SETTINGS Settings, + /*_In_ */ WDF_POWER_POLICY_S0_IDLE_CAPABILITIES IdleCaps + ) +{ + RtlZeroMemory(Settings, sizeof(WDF_DEVICE_POWER_POLICY_IDLE_SETTINGS)); + + Settings->Size = sizeof(WDF_DEVICE_POWER_POLICY_IDLE_SETTINGS); + + Settings->IdleTimeout = IdleTimeoutDefaultValue; + Settings->UserControlOfIdleSettings = IdleAllowUserControl; + Settings->Enabled = WdfUseDefault; + Settings->PowerUpIdleDeviceOnSystemWake = WdfUseDefault; + Settings->IdleTimeoutType = DriverManagedIdleTimeout; + Settings->ExcludeD3Cold = WdfUseDefault; + + Settings->IdleCaps = IdleCaps; + + switch (IdleCaps) { + case IdleUsbSelectiveSuspend: + case IdleCanWakeFromS0: + Settings->DxState = PowerDeviceMaximum; + break; + + case IdleCannotWakeFromS0: + Settings->DxState = PowerDeviceD3; + break; + } +} + +// Copied from c:/slam/WDK/inc/wdf/kmdf/1.9/wdfdevice.h, line 907. +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_ARM_WAKE_FROM_S0) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DEVICE_ARM_WAKE_FROM_S0( +/* __in */ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_ARM_WAKE_FROM_S0 *PFN_WDF_DEVICE_ARM_WAKE_FROM_S0; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_ARM_WAKE_FROM_SX) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DEVICE_ARM_WAKE_FROM_SX( +/* __in */ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_ARM_WAKE_FROM_SX *PFN_WDF_DEVICE_ARM_WAKE_FROM_SX; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_ARM_WAKE_FROM_SX_WITH_REASON) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DEVICE_ARM_WAKE_FROM_SX_WITH_REASON( +/* __in */ + WDFDEVICE Device, +/* __in */ + BOOLEAN DeviceWakeEnabled, +/* __in */ + BOOLEAN ChildrenArmedForWake + ); + +typedef EVT_WDF_DEVICE_ARM_WAKE_FROM_SX_WITH_REASON *PFN_WDF_DEVICE_ARM_WAKE_FROM_SX_WITH_REASON; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_DISARM_WAKE_FROM_S0) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +VOID +EVT_WDF_DEVICE_DISARM_WAKE_FROM_S0( +/* __in */ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_DISARM_WAKE_FROM_S0 *PFN_WDF_DEVICE_DISARM_WAKE_FROM_S0; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_DISARM_WAKE_FROM_SX) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +VOID +EVT_WDF_DEVICE_DISARM_WAKE_FROM_SX( +/* __in */ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_DISARM_WAKE_FROM_SX *PFN_WDF_DEVICE_DISARM_WAKE_FROM_SX; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_WAKE_FROM_S0_TRIGGERED) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +VOID +EVT_WDF_DEVICE_WAKE_FROM_S0_TRIGGERED( +/* __in */ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_WAKE_FROM_S0_TRIGGERED *PFN_WDF_DEVICE_WAKE_FROM_S0_TRIGGERED; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_WAKE_FROM_SX_TRIGGERED) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +VOID +EVT_WDF_DEVICE_WAKE_FROM_SX_TRIGGERED( +/* __in */ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_WAKE_FROM_SX_TRIGGERED *PFN_WDF_DEVICE_WAKE_FROM_SX_TRIGGERED; + +// Copied from $SLAM/WDK/inc/wdf/kmdf/1.9/wdfdevice.h, line 695. +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_D0_ENTRY) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DEVICE_D0_ENTRY( +/* __in */ + WDFDEVICE Device, +/* __in */ + WDF_POWER_DEVICE_STATE PreviousState + ); +typedef EVT_WDF_DEVICE_D0_ENTRY *PFN_WDF_DEVICE_D0_ENTRY; + +// Copied from $SLAM/WDK/inc/wdf/kmdf/1.9/, line 723. +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_D0_EXIT) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DEVICE_D0_EXIT( +/* __in */ + WDFDEVICE Device, +/* __in */ + WDF_POWER_DEVICE_STATE TargetState + ); +typedef EVT_WDF_DEVICE_D0_EXIT *PFN_WDF_DEVICE_D0_EXIT; + +// Copied from $SLAM/WDK/inc/wdf/kmdf/1.9/, line 751. +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_PREPARE_HARDWARE) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DEVICE_PREPARE_HARDWARE( +/* __in */ + WDFDEVICE Device, +/* __in */ + WDFCMRESLIST ResourcesRaw, +/* __in */ + WDFCMRESLIST ResourcesTranslated + ); + +typedef EVT_WDF_DEVICE_PREPARE_HARDWARE *PFN_WDF_DEVICE_PREPARE_HARDWARE; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_RELEASE_HARDWARE) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +NTSTATUS +EVT_WDF_DEVICE_RELEASE_HARDWARE( +/* __in */ + WDFDEVICE Device, +/* __in */ + WDFCMRESLIST ResourcesTranslated + ); +typedef EVT_WDF_DEVICE_RELEASE_HARDWARE *PFN_WDF_DEVICE_RELEASE_HARDWARE; + +typedef +/* __drv_functionClass(EVT_WDF_DEVICE_SELF_MANAGED_IO_CLEANUP) */ +/* __drv_sameIRQL */ +/* __drv_maxIRQL(PASSIVE_LEVEL) */ +VOID +EVT_WDF_DEVICE_SELF_MANAGED_IO_CLEANUP( +/* __in */ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_SELF_MANAGED_IO_CLEANUP *PFN_WDF_DEVICE_SELF_MANAGED_IO_CLEANUP; + +typedef +NTSTATUS +EVT_WDF_DEVICE_SELF_MANAGED_IO_INIT( + _In_ + WDFDEVICE Device + ); + +typedef EVT_WDF_DEVICE_SELF_MANAGED_IO_INIT *PFN_WDF_DEVICE_SELF_MANAGED_IO_INIT; + +typedef +VOID +EVT_WDF_DEVICE_FILE_CREATE( + _In_ + WDFDEVICE Device, + _In_ + WDFREQUEST Request, + _In_ + WDFFILEOBJECT FileObject + ); + +typedef EVT_WDF_DEVICE_FILE_CREATE *PFN_WDF_DEVICE_FILE_CREATE; + +typedef +VOID +EVT_WDF_FILE_CLOSE( + _In_ + WDFFILEOBJECT FileObject + ); + +typedef EVT_WDF_FILE_CLOSE *PFN_WDF_FILE_CLOSE; + +typedef +// _Function_class_(EVT_WDF_DEVICE_D0_EXIT_PRE_INTERRUPTS_DISABLED) +// _IRQL_requires_same_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_DEVICE_D0_EXIT_PRE_INTERRUPTS_DISABLED( + // _In_ + WDFDEVICE Device, + // _In_ + WDF_POWER_DEVICE_STATE TargetState + ); + +typedef EVT_WDF_DEVICE_D0_EXIT_PRE_INTERRUPTS_DISABLED *PFN_WDF_DEVICE_D0_EXIT_PRE_INTERRUPTS_DISABLED; + +// Copied from $SLAM/WDK/inc/wdf/kmdf/1.9/wdfdevice.h, line 995. +typedef struct _WDF_PNPPOWER_EVENT_CALLBACKS { + ULONG Size; + PFN_WDF_DEVICE_D0_ENTRY EvtDeviceD0Entry; + PFN_WDF_DEVICE_D0_ENTRY_POST_INTERRUPTS_ENABLED EvtDeviceD0EntryPostInterruptsEnabled; + PFN_WDF_DEVICE_D0_EXIT EvtDeviceD0Exit; + PFN_WDF_DEVICE_D0_EXIT_PRE_INTERRUPTS_DISABLED EvtDeviceD0ExitPreInterruptsDisabled; + PFN_WDF_DEVICE_PREPARE_HARDWARE EvtDevicePrepareHardware; + PFN_WDF_DEVICE_RELEASE_HARDWARE EvtDeviceReleaseHardware; + PFN_WDF_DEVICE_SELF_MANAGED_IO_CLEANUP EvtDeviceSelfManagedIoCleanup; +/* PFN_WDF_DEVICE_SELF_MANAGED_IO_FLUSH EvtDeviceSelfManagedIoFlush; */ + PFN_WDF_DEVICE_SELF_MANAGED_IO_INIT EvtDeviceSelfManagedIoInit; + PFN_WDF_DEVICE_SELF_MANAGED_IO_SUSPEND EvtDeviceSelfManagedIoSuspend; + PFN_WDF_DEVICE_SELF_MANAGED_IO_RESTART EvtDeviceSelfManagedIoRestart; +/* PFN_WDF_DEVICE_SURPRISE_REMOVAL EvtDeviceSurpriseRemoval; */ +/* PFN_WDF_DEVICE_QUERY_REMOVE EvtDeviceQueryRemove; */ +/* PFN_WDF_DEVICE_QUERY_STOP EvtDeviceQueryStop; */ +/* PFN_WDF_DEVICE_USAGE_NOTIFICATION EvtDeviceUsageNotification; */ +/* PFN_WDF_DEVICE_RELATIONS_QUERY EvtDeviceRelationsQuery; */ +} WDF_PNPPOWER_EVENT_CALLBACKS, *PWDF_PNPPOWER_EVENT_CALLBACKS; + +typedef EVT_WDF_DEVICE_WAKE_FROM_SX_TRIGGERED *PFN_WDF_DEVICE_WAKE_FROM_SX_TRIGGERED; + +typedef struct _WDF_POWER_POLICY_EVENT_CALLBACKS { + ULONG Size; + PFN_WDF_DEVICE_ARM_WAKE_FROM_S0 EvtDeviceArmWakeFromS0; + PFN_WDF_DEVICE_DISARM_WAKE_FROM_S0 EvtDeviceDisarmWakeFromS0; + PFN_WDF_DEVICE_WAKE_FROM_S0_TRIGGERED EvtDeviceWakeFromS0Triggered; + PFN_WDF_DEVICE_ARM_WAKE_FROM_SX EvtDeviceArmWakeFromSx; + PFN_WDF_DEVICE_DISARM_WAKE_FROM_SX EvtDeviceDisarmWakeFromSx; + PFN_WDF_DEVICE_WAKE_FROM_SX_TRIGGERED EvtDeviceWakeFromSxTriggered; + PFN_WDF_DEVICE_ARM_WAKE_FROM_SX_WITH_REASON EvtDeviceArmWakeFromSxWithReason; +} WDF_POWER_POLICY_EVENT_CALLBACKS, *PWDF_POWER_POLICY_EVENT_CALLBACKS; + +typedef +NTSTATUS +EVT_WDF_DEVICE_SELF_MANAGED_IO_INIT( + _In_ + WDFDEVICE Device + ); + +VOID +/* FORCEINLINE */ +WDF_POWER_POLICY_EVENT_CALLBACKS_INIT( + /* __out */ PWDF_POWER_POLICY_EVENT_CALLBACKS Callbacks + ) +{ + // Patch: + /* RtlZeroMemory(Callbacks, sizeof(WDF_POWER_POLICY_EVENT_CALLBACKS)); */ + Callbacks->Size = 0; + Callbacks->EvtDeviceArmWakeFromS0 = 0; + Callbacks->EvtDeviceDisarmWakeFromS0 = 0; + Callbacks->EvtDeviceWakeFromS0Triggered = 0; + Callbacks->EvtDeviceArmWakeFromSx = 0; + Callbacks->EvtDeviceDisarmWakeFromSx = 0; + Callbacks->EvtDeviceWakeFromSxTriggered = 0; + Callbacks->EvtDeviceArmWakeFromSxWithReason = 0; + + Callbacks->Size = sizeof(WDF_POWER_POLICY_EVENT_CALLBACKS); +} + +// line 1818 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +PDEVICE_OBJECT +(*PFN_WDFDEVICEWDMGETDEVICEOBJECT)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFDEVICE Device + ); + +// _IRQL_requires_max_(DISPATCH_LEVEL) +PDEVICE_OBJECT +FORCEINLINE +WdfDeviceWdmGetDeviceObject( + // _In_ + WDFDEVICE Device + ) +{ + // return ((PFN_WDFDEVICEWDMGETDEVICEOBJECT) WdfFunctions[WdfDeviceWdmGetDeviceObjectTableIndex])(WdfDriverGlobals, Device); + PDEVICE_OBJECT o; + return o; +} + +VOID +/* FORCEINLINE */ +WDF_PNPPOWER_EVENT_CALLBACKS_INIT( + /* __out */ PWDF_PNPPOWER_EVENT_CALLBACKS Callbacks + ) +{ + // Patch: + /* RtlZeroMemory(Callbacks, sizeof(WDF_PNPPOWER_EVENT_CALLBACKS)); */ + Callbacks->Size = 0; + Callbacks->EvtDeviceD0Entry = 0; + Callbacks->EvtDeviceD0Exit = 0; + Callbacks->EvtDevicePrepareHardware = 0; + Callbacks->EvtDeviceReleaseHardware = 0; + Callbacks->EvtDeviceSelfManagedIoCleanup = 0; + + Callbacks->Size = sizeof(WDF_PNPPOWER_EVENT_CALLBACKS); +} + +//copied from wdf/kmdf/1.7/wdfdevice.h, line 1195 + +typedef struct _WDF_DEVICE_POWER_CAPABILITIES { + // + // Size of the structure in bytes + // + ULONG Size; + + WDF_TRI_STATE DeviceD1; + WDF_TRI_STATE DeviceD2; + + WDF_TRI_STATE WakeFromD0; + WDF_TRI_STATE WakeFromD1; + WDF_TRI_STATE WakeFromD2; + WDF_TRI_STATE WakeFromD3; + + // + // Default value PowerDeviceMaximum indicates not to set this value + // + DEVICE_POWER_STATE DeviceState[PowerSystemMaximum]; + + // + // Default value PowerDeviceMaximum, PowerSystemMaximum indicates not to + // set this value. + // + DEVICE_POWER_STATE DeviceWake; + SYSTEM_POWER_STATE SystemWake; + + // + // Default values of -1 indicate not to set this value + // + ULONG D1Latency; + ULONG D2Latency; + ULONG D3Latency; + + // + // Ideal Dx state for the device to be put into when the machine moves into + // Sx and the device is not armed for wake. By default, the default will be + // placed into D3. If IdealDxStateForSx is lighter then + // DeviceState[Sx], then DeviceState[Sx] will be used as the Dx state. + // + DEVICE_POWER_STATE IdealDxStateForSx; + +} WDF_DEVICE_POWER_CAPABILITIES, *PWDF_DEVICE_POWER_CAPABILITIES; + +// wdf/kmdf/1.9/wdfdevice.h +// line 1229 +typedef struct _WDF_DEVICE_STATE { + ULONG Size; + WDF_TRI_STATE Disabled; + WDF_TRI_STATE DontDisplayInUI; + WDF_TRI_STATE Failed; + WDF_TRI_STATE NotDisableable; + WDF_TRI_STATE Removed; + WDF_TRI_STATE ResourcesChanged; +} WDF_DEVICE_STATE, *PWDF_DEVICE_STATE; + +// Copied from c:/slam/WDK/inc/wdf/kmdf/1.9/wdfdevice.h, line 2232. +// +// WDF Function: WdfDeviceInitSetPnpPowerEventCallbacks +// +typedef +/* __drv_maxIRQL(DISPATCH_LEVEL) */ +/* WDFAPI */ +VOID +(*PFN_WDFDEVICEINITSETPNPPOWEREVENTCALLBACKS)( +/* __in */ + PWDF_DRIVER_GLOBALS DriverGlobals, +/* __in */ + PWDFDEVICE_INIT DeviceInit, +/* __in */ + PWDF_PNPPOWER_EVENT_CALLBACKS PnpPowerEventCallbacks + ); + +// Patch: model of WDFDEVICE_INIT. Not in original wdfdevice.h file. +// WDFDEVICE_INIT is not defined in WDK/inc/wdf/kmdf/1.9/*.h. +/* typedef struct _WDFDEVICE_INIT { */ +/* WDF_PNPPOWER_EVENT_CALLBACKS PnpPowerEventCallbacks; */ + +/* } WDFDEVICE_INIT; */ +// SI: WDFDEVICE_INIT is an opaque pointer +struct _WDFDEVICE_INIT { + WDF_PNPPOWER_EVENT_CALLBACKS PnpPowerEventCallbacks; +}; +typedef struct _WDFDEVICE_INIT *WDFDEVICE_INIT; + +// SLAyer: implemented in specific harnesses. +__checkReturn +__drv_maxIRQL(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfDeviceCreate( __inout + PWDFDEVICE_INIT* DeviceInit, + __in_opt + PWDF_OBJECT_ATTRIBUTES DeviceAttributes, + __out + WDFDEVICE* Device + ) ; + +/* __drv_maxIRQL(DISPATCH_LEVEL) */ +VOID +/* FORCEINLINE */ +WdfDeviceInitSetPnpPowerEventCallbacks( +/* __in */ + PWDFDEVICE_INIT DeviceInit, +/* __in */ + PWDF_PNPPOWER_EVENT_CALLBACKS PnpPowerEventCallbacks + ) +{ + // SI: This is the original implementation in wdfdevice.h: + // ((PFN_WDFDEVICEINITSETPNPPOWEREVENTCALLBACKS) WdfFunctions[WdfDeviceInitSetPnpPowerEventCallbacksTableIndex])(WdfDriverGlobals, DeviceInit, PnpPowerEventCallbacks); + // SI: SDV's wdf_sdv_stubs.c provides no implementation for this + // function, relying instead on it's dispatch method discovery + // mechanism to work out which are the PnpPowerEventCallbacks + // functions. We should be able to use the same. (Alternatively, + // we could implement a WdfFunctions table.) +} + +VOID WdfDeviceInitSetExclusive( + /* [in] */ PWDFDEVICE_INIT DeviceInit, + /* [in] */ BOOLEAN IsExclusive +) +{ + // Patch: leave as stub? +} + + +// Copied from c:/slam/WDK/inc/wdf/kmdf/1.9/wdfdevice.h, line 2877. +__checkReturn +__drv_maxIRQL(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfDeviceCreate( + __inout + PWDFDEVICE_INIT* DeviceInit, + __in_opt + PWDF_OBJECT_ATTRIBUTES DeviceAttributes, + __out + WDFDEVICE* Device + ); + +WDFDEVICE MkSLAyerWdfDevice(PWDF_OBJECT_ATTRIBUTES DeviceAttributes) +{ + WDFDEVICE dev; + dev = (WDFDEVICE)_SLAyer_malloc(sizeof(SLAyer_WDFOBJECT)); + dev->typ = SLAyerWdfDevice; + dev->Context = + (DeviceAttributes == WDF_NO_OBJECT_ATTRIBUTES) ? NULL : + (*(DeviceAttributes->MkContext))() ; + dev->typ = SLAyerWdfDevice; + dev->typDevice.Queue = NULL; + dev->typDevice.WmiInstance1 = NULL; + dev->typDevice.WmiInstance2 = NULL; + dev->typDevice.WmiInstance3 = NULL; + return dev; +} + + __checkReturn + __drv_maxIRQL(PASSIVE_LEVEL) + NTSTATUS + FORCEINLINE + WdfDeviceCreate( __inout + PWDFDEVICE_INIT* DeviceInit, + __in_opt + PWDF_OBJECT_ATTRIBUTES DeviceAttributes, + __out + WDFDEVICE* Device + ) + { + // return ((PFN_WDFDEVICECREATE) WdfFunctions[WdfDeviceCreateTableIndex])(WdfDriverGlobals, DeviceInit, DeviceAttributes, Device); + NTSTATUS status; + WDFDEVICE dev; + + // First time called. + if (SL_num_of_devices == SL_devices_zero) { + dev = MkSLAyerWdfDevice(DeviceAttributes); + // Keep a handle on the device + SL_Device_one = dev; + SL_num_of_devices = SL_devices_one; + // returns + *Device = dev; + status = STATUS_SUCCESS; + } + // Second time called. + else if (SL_num_of_devices == SL_devices_one) { + dev = MkSLAyerWdfDevice(DeviceAttributes); + // Keep a handle on the device + SL_Device_two = dev; + SL_num_of_devices = SL_devices_two; + // returns. + *Device = dev; + status = STATUS_SUCCESS; + } + // Called >2 times. + else { + status = STATUS_UNSUCCESSFUL; + } + + // SI: We should also free DeviceInit as it'll otherwise leak. + // free(DeviceInit); DeviceInit = NULL; + + return status; + } + +// line 1294. +typedef struct _WDF_DEVICE_PNP_CAPABILITIES { + // + // Size of the structure in bytes + // + ULONG Size; + + // + // NOTE: To mark a PDO as raw, call WdfPdoInitAssignRawDevice + // + + WDF_TRI_STATE LockSupported; + WDF_TRI_STATE EjectSupported; + WDF_TRI_STATE Removable; + WDF_TRI_STATE DockDevice; + WDF_TRI_STATE UniqueID; + WDF_TRI_STATE SilentInstall; + WDF_TRI_STATE SurpriseRemovalOK; + WDF_TRI_STATE HardwareDisabled; + WDF_TRI_STATE NoDisplayInUI; + + // + // Default values of -1 indicate not to set this value + // + ULONG Address; + ULONG UINumber; + +} WDF_DEVICE_PNP_CAPABILITIES, *PWDF_DEVICE_PNP_CAPABILITIES; + +// line 1330 +VOID +FORCEINLINE +WDF_DEVICE_POWER_POLICY_WAKE_SETTINGS_INIT( + /*_Out_*/ PWDF_DEVICE_POWER_POLICY_WAKE_SETTINGS Settings + ) +{ + RtlZeroMemory(Settings, sizeof(WDF_DEVICE_POWER_POLICY_WAKE_SETTINGS)); + + Settings->Size = sizeof(WDF_DEVICE_POWER_POLICY_WAKE_SETTINGS); + + Settings->Enabled = WdfUseDefault; + Settings->DxState = PowerDeviceMaximum; + Settings->UserControlOfWakeSettings = WakeAllowUserControl; +} + +// line 2330 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFDEVICEASSIGNS0IDLESETTINGS)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFDEVICE Device, + // _In_ + PWDF_DEVICE_POWER_POLICY_IDLE_SETTINGS Settings + ); + +/* PS#637 --KK */ +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +NTSTATUS +FORCEINLINE +WdfDeviceAssignS0IdleSettings( + // _In_ + WDFDEVICE Device, + // _In_ + PWDF_DEVICE_POWER_POLICY_IDLE_SETTINGS Settings + ) +{ + // return ((PFN_WDFDEVICEASSIGNS0IDLESETTINGS) WdfFunctions[WdfDeviceAssignS0IdleSettingsTableIndex])(WdfDriverGlobals, Device, Settings); + NTSTATUS status; + return status; +} + +// line 2361 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFDEVICEASSIGNSXWAKESETTINGS)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFDEVICE Device, + // _In_ + PWDF_DEVICE_POWER_POLICY_WAKE_SETTINGS Settings + ); + +/* PS#637 --KK */ +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +NTSTATUS +FORCEINLINE +WdfDeviceAssignSxWakeSettings( + // _In_ + WDFDEVICE Device, + // _In_ + PWDF_DEVICE_POWER_POLICY_WAKE_SETTINGS Settings + ) +{ + // return ((PFN_WDFDEVICEASSIGNSXWAKESETTINGS) WdfFunctions[WdfDeviceAssignSxWakeSettingsTableIndex])(WdfDriverGlobals, Device, Settings); + NTSTATUS status; + return status; +} + +// line 3091 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +VOID +(*PFN_WDFDEVICEINITSETFILEOBJECTCONFIG)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + PWDFDEVICE_INIT DeviceInit, + // _In_ + PWDF_FILEOBJECT_CONFIG FileObjectConfig, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES FileObjectAttributes + ); + +// _IRQL_requires_max_(DISPATCH_LEVEL) +VOID +FORCEINLINE +WdfDeviceInitSetFileObjectConfig( + // _In_ + PWDFDEVICE_INIT DeviceInit, + // _In_ + PWDF_FILEOBJECT_CONFIG FileObjectConfig, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES FileObjectAttributes + ) +{ + //((PFN_WDFDEVICEINITSETFILEOBJECTCONFIG) WdfFunctions[WdfDeviceInitSetFileObjectConfigTableIndex])(WdfDriverGlobals, DeviceInit, FileObjectConfig, FileObjectAttributes); +} + +// SLAyer: implemented. +NTSTATUS +WdfRequestRetrieveInputBuffer +( + WDFREQUEST Request, + size_t MinimumRequiredSize, + PVOID *Buffer, + size_t *Length + ) +{ + int nondet; + NTSTATUS res; + + if (nondet) { + *Buffer = Request->typRequest.InputBuffer; + *Length = sizeof(Request->typRequest.InputBuffer); + res = STATUS_SUCCESS ; + } else { + res = STATUS_UNSUCCESSFUL; + } + return res; +} + +// SLAyer: probably needs implementing +NTSTATUS WdfRequestRetrieveOutputMemory( + /* [in] */ WDFREQUEST Request, + /* [out] */ WDFMEMORY *Memory +) +{ + SLAyer_nondetT(NTSTATUS); +} + +NTSTATUS WdfRequestRetrieveInputMemory( + /* [in] */ WDFREQUEST Request, + /* [out] */ WDFMEMORY *Memory +) +{ + SLAyer_nondetT(NTSTATUS); +} + +VOID WdfDeviceInitSetDeviceType(PWDFDEVICE_INIT DeviceInit, DEVICE_TYPE DeviceType) +{ +} + +// PS #644 DeviceInit lifetime +VOID WdfDeviceInitFree(PWDFDEVICE_INIT DeviceInit) +{ + // free(DeviceInit); +} + +VOID WDF_DEVICE_PNP_CAPABILITIES_INIT(PWDF_DEVICE_PNP_CAPABILITIES Caps) +{ +} + +VOID WdfDeviceSetPnpCapabilities(WDFDEVICE Device, PWDF_DEVICE_PNP_CAPABILITIES PnpCapabilities) +{ +} + +VOID WDF_DEVICE_POWER_CAPABILITIES_INIT(PWDF_DEVICE_POWER_CAPABILITIES Caps) +{ +} + +VOID WdfDeviceSetPowerCapabilities(WDFDEVICE Device, PWDF_DEVICE_POWER_CAPABILITIES PowerCapabilities) +{ +} + +NTSTATUS WdfDeviceAssignMofResourceName( + /*[in]*/ WDFDEVICE Device, + /*[in]*/ PCUNICODE_STRING MofResourceName +) +{ + NTSTATUS status; + return status; +} + +typedef ULONG ACCESS_MASK; + +NTSTATUS WdfDeviceOpenRegistryKey( + /*[in]*/ WDFDEVICE Device, + /*[in]*/ ULONG DeviceInstanceKeyType, + /*[in]*/ ACCESS_MASK DesiredAccess, + /*[in, optional]*/ PWDF_OBJECT_ATTRIBUTES KeyAttributes, + /*[out]*/ WDFKEY *Key +) +{ + SLAyer_nondetT(NTSTATUS); +} + +// line 1389 +VOID +FORCEINLINE +WDF_DEVICE_STATE_INIT( + /*_Out_*/ PWDF_DEVICE_STATE PnpDeviceState + ) +{ + RtlZeroMemory(PnpDeviceState, sizeof(WDF_DEVICE_STATE)); + + PnpDeviceState->Size = sizeof(WDF_DEVICE_STATE); + + // + // Initializes all of the fields to the WdfUseDefault enum value + // + PnpDeviceState->Disabled = WdfUseDefault; + PnpDeviceState->DontDisplayInUI = WdfUseDefault; + PnpDeviceState->Failed = WdfUseDefault; + PnpDeviceState->NotDisableable = WdfUseDefault; + PnpDeviceState->Removed = WdfUseDefault; + PnpDeviceState->ResourcesChanged = WdfUseDefault; +} + +// line 2985 +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfDeviceInitAssignName( + // _In_ + PWDFDEVICE_INIT DeviceInit, + // _In_opt_ + PCUNICODE_STRING DeviceName + ) +{ + /* Can't really do what the documentation wants me to do, since + * DeviceInit is an opaque structure. + */ + // return ((PFN_WDFDEVICEINITASSIGNNAME) WdfFunctions[WdfDeviceInitAssignNameTableIndex])(WdfDriverGlobals, DeviceInit, DeviceName); + int x; + NTSTATUS status; + status = x ? STATUS_SUCCESS + : STATUS_INSUFFICIENT_RESOURCES; + return status; +} + +// line 1764 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +VOID +(*PFN_WDFDEVICESETDEVICESTATE)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFDEVICE Device, + // _In_ + PWDF_DEVICE_STATE DeviceState + ); +/* PS#637 --KK */ +// _IRQL_requires_max_(DISPATCH_LEVEL) +VOID +FORCEINLINE +WdfDeviceSetDeviceState( + // _In_ + WDFDEVICE Device, + // _In_ + PWDF_DEVICE_STATE DeviceState + ) +{ + // ((PFN_WDFDEVICESETDEVICESTATE) WdfFunctions[WdfDeviceSetDeviceStateTableIndex])(WdfDriverGlobals, Device, DeviceState); +} + +NTSTATUS WdfDeviceCreateDeviceInterface( + /*[in]*/ WDFDEVICE Device, + /*[in]*/ const GUID *InterfaceClassGUID, + /*[in, optional]*/ PCUNICODE_STRING ReferenceString +) +{ + SLAyer_nondetT(NTSTATUS); +} + +VOID WdfDeviceSetBusInformationForChildren( + /*[in]*/ WDFDEVICE Device, + /*[in]*/ PPNP_BUS_INFORMATION BusInformation +) +{ +} + +// SI: wrong. We probably need a harness IoTarget +WDFIOTARGET WdfDeviceGetIoTarget( + WDFDEVICE Device +) +{ + return NULL; +} + +NTSTATUS WdfIoTargetCreate( + /*[in]*/ WDFDEVICE Device, + /*[in, optional]*/ PWDF_OBJECT_ATTRIBUTES IoTargetAttributes, + /*[out]*/ WDFIOTARGET *IoTarget +) +{ + int x; + NTSTATUS status; + + if (x) { + WDFIOTARGET target; + target = (WDFIOTARGET)_SLAyer_malloc(sizeof(SLAyer_WDFOBJECT)); + target->typ = SLAyerWdfIoTarget; + target->Context = + (IoTargetAttributes == WDF_NO_OBJECT_ATTRIBUTES) ? NULL : + (*(IoTargetAttributes->MkContext))() ; + SL_IoTarget = target; + *IoTarget = SL_IoTarget; + status = STATUS_SUCCESS; + } else { + status = STATUS_UNSUCCESSFUL; + } + return status; +} + +NTSTATUS WdfIoTargetClose( + /*[in]*/ WDFIOTARGET *IoTarget +) +{ + SLAyer_nondetT(NTSTATUS); +} + +// line 2143 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +//WDFAPI +WDFDRIVER +(*PFN_WDFDEVICEGETDRIVER)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFDEVICE Device + ); + +/* Reimplementing myself. This function is called from + * WdfDeviceGetDriver, but the WDF implements this funciton using some + * unknown array. --KK #PS637 + */ +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFDRIVER +FORCEINLINE +WdfDeviceGetDriver( + //_In_ + WDFDEVICE Device + ) +{ + //return ((PFN_WDFDEVICEGETDRIVER) WdfFunctions[WdfDeviceGetDriverTableIndex])(WdfDriverGlobals, Device); + WDFDRIVER d; + return d; +} + +// line 2630 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +// WDFAPI +VOID +(*PFN_WDFDEVICEINITSETPOWERPOLICYEVENTCALLBACKS)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + PWDFDEVICE_INIT DeviceInit, + // _In_ + PWDF_POWER_POLICY_EVENT_CALLBACKS PowerPolicyEventCallbacks + ); + +/* PS#637 --KK */ +// _IRQL_requires_max_(DISPATCH_LEVEL) +VOID +FORCEINLINE +WdfDeviceInitSetPowerPolicyEventCallbacks( + // _In_ + PWDFDEVICE_INIT DeviceInit, + // _In_ + PWDF_POWER_POLICY_EVENT_CALLBACKS PowerPolicyEventCallbacks + ) +{ + //((PFN_WDFDEVICEINITSETPOWERPOLICYEVENTCALLBACKS) WdfFunctions[WdfDeviceInitSetPowerPolicyEventCallbacksTableIndex])(WdfDriverGlobals, DeviceInit, PowerPolicyEventCallbacks); +} + +// line 3505 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFDEVICEALLOCANDQUERYPROPERTY)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFDEVICE Device, + // _In_ + DEVICE_REGISTRY_PROPERTY DeviceProperty, + // _In_ + // _Strict_type_match_ + POOL_TYPE PoolType, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES PropertyMemoryAttributes, + // _Out_ + WDFMEMORY* PropertyMemory + ); + +/* PS#637 */ +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfDeviceAllocAndQueryProperty( + // _In_ + WDFDEVICE Device, + // _In_ + DEVICE_REGISTRY_PROPERTY DeviceProperty, + // _In_ + // _Strict_type_match_ + POOL_TYPE PoolType, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES PropertyMemoryAttributes, + // _Out_ + WDFMEMORY* PropertyMemory + ) +{ + // return ((PFN_WDFDEVICEALLOCANDQUERYPROPERTY) WdfFunctions[WdfDeviceAllocAndQueryPropertyTableIndex])(WdfDriverGlobals, Device, DeviceProperty, PoolType, PropertyMemoryAttributes, PropertyMemory); + NTSTATUS status; + return status; +} + +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfDeviceCreateSymbolicLink( + // _In_ + WDFDEVICE Device, + // _In_ + PCUNICODE_STRING SymbolicLinkName + ) +{ + // return ((PFN_WDFDEVICECREATESYMBOLICLINK) WdfFunctions[WdfDeviceCreateSymbolicLinkTableIndex])(WdfDriverGlobals, Device, SymbolicLinkName); + + // Don't know what this method is supposed to do. + NTSTATUS status; + return status; +} + +/****************************************************************************** + * File: wdfrequest.h + ******************************************************************************/ +// Copied from line 42 +typedef enum _WDF_REQUEST_TYPE { + WdfRequestTypeCreate = 0x0, + WdfRequestTypeCreateNamedPipe = 0x1, + WdfRequestTypeClose = 0x2, + WdfRequestTypeRead = 0x3, + WdfRequestTypeWrite = 0x4, + WdfRequestTypeQueryInformation = 0x5, + WdfRequestTypeSetInformation = 0x6, + WdfRequestTypeQueryEA = 0x7, + WdfRequestTypeSetEA = 0x8, + WdfRequestTypeFlushBuffers = 0x9, + WdfRequestTypeQueryVolumeInformation = 0xa, + WdfRequestTypeSetVolumeInformation = 0xb, + WdfRequestTypeDirectoryControl = 0xc, + WdfRequestTypeFileSystemControl = 0xd, + WdfRequestTypeDeviceControl = 0xe, + WdfRequestTypeDeviceControlInternal = 0xf, + WdfRequestTypeShutdown = 0x10, + WdfRequestTypeLockControl = 0x11, + WdfRequestTypeCleanup = 0x12, + WdfRequestTypeCreateMailSlot = 0x13, + WdfRequestTypeQuerySecurity = 0x14, + WdfRequestTypeSetSecurity = 0x15, + WdfRequestTypePower = 0x16, + WdfRequestTypeSystemControl = 0x17, + WdfRequestTypeDeviceChange = 0x18, + WdfRequestTypeQueryQuota = 0x19, + WdfRequestTypeSetQuota = 0x1A, + WdfRequestTypePnp = 0x1B, + WdfRequestTypeOther =0x1C, + WdfRequestTypeUsb = 0x40, + WdfRequestTypeNoFormat = 0xFF, + WdfRequestTypeMax, +} WDF_REQUEST_TYPE; + +// line 77 +typedef enum _WDF_REQUEST_REUSE_FLAGS { + WDF_REQUEST_REUSE_NO_FLAGS = 0x00000000, + WDF_REQUEST_REUSE_SET_NEW_IRP = 0x00000001, +} WDF_REQUEST_REUSE_FLAGS; + +// kmdf/1.11/wdfrequest.h, line 93 +typedef enum _WDF_REQUEST_SEND_OPTIONS_FLAGS { + WDF_REQUEST_SEND_OPTION_TIMEOUT = 0x00000001, + WDF_REQUEST_SEND_OPTION_SYNCHRONOUS = 0x00000002, + WDF_REQUEST_SEND_OPTION_IGNORE_TARGET_STATE = 0x00000004, + WDF_REQUEST_SEND_OPTION_SEND_AND_FORGET = 0x00000008, +} WDF_REQUEST_SEND_OPTIONS_FLAGS; + +// line 119 +typedef struct _WDF_REQUEST_PARAMETERS { + USHORT Size; +/* + UCHAR MinorFunction; + WDF_REQUEST_TYPE Type; + // The following user parameters are based on the service that is being + // invoked. Drivers and file systems can determine which set to use based + // on the above major and minor function codes. + union { + // + // System service parameters for: Create + // + struct { + PIO_SECURITY_CONTEXT SecurityContext; + ULONG Options; + USHORT POINTER_ALIGNMENT FileAttributes; + USHORT ShareAccess; + ULONG POINTER_ALIGNMENT EaLength; + } Create; + // System service parameters for: Read + struct { + size_t Length; + ULONG POINTER_ALIGNMENT Key; + LONGLONG DeviceOffset; + } Read; + // System service parameters for: Write + struct { + size_t Length; + ULONG POINTER_ALIGNMENT Key; + LONGLONG DeviceOffset; + } Write; + // System service parameters for: Device Control + // Note that the user's output buffer is stored in the UserBuffer field + // and the user's input buffer is stored in the SystemBuffer field. + struct { + size_t OutputBufferLength; + size_t POINTER_ALIGNMENT InputBufferLength; + ULONG POINTER_ALIGNMENT IoControlCode; + PVOID Type3InputBuffer; + } DeviceIoControl; + struct { + PVOID Arg1; + PVOID Arg2; + ULONG POINTER_ALIGNMENT IoControlCode; + PVOID Arg4; + } Others; + } Parameters; +*/ +} WDF_REQUEST_PARAMETERS, *PWDF_REQUEST_PARAMETERS; + +// copied from line 203 +typedef struct _WDF_USB_REQUEST_COMPLETION_PARAMS *PWDF_USB_REQUEST_COMPLETION_PARAMS; + +typedef struct _WDF_REQUEST_COMPLETION_PARAMS { + // + // Size of the structure in bytes + // + ULONG Size; + + WDF_REQUEST_TYPE Type; + IO_STATUS_BLOCK IoStatus; + + union { + struct { + WDFMEMORY Buffer; + size_t Length; + size_t Offset; + } Write; + + struct { + WDFMEMORY Buffer; + size_t Length; + size_t Offset; + } Read; + + struct { + ULONG IoControlCode; + + struct { + WDFMEMORY Buffer; + size_t Offset; + } Input; + + struct { + WDFMEMORY Buffer; + size_t Offset; + size_t Length; + } Output; + } Ioctl; + + struct { + union { + PVOID Ptr; + ULONG_PTR Value; + } Argument1; + union { + PVOID Ptr; + ULONG_PTR Value; + } Argument2; + union { + PVOID Ptr; + ULONG_PTR Value; + } Argument3; + union { + PVOID Ptr; + ULONG_PTR Value; + } Argument4; + } Others; + + struct { + PWDF_USB_REQUEST_COMPLETION_PARAMS Completion; + } Usb; + } Parameters; + +} WDF_REQUEST_COMPLETION_PARAMS, *PWDF_REQUEST_COMPLETION_PARAMS; + +// Copied from line 281 + typedef +// _Function_class_(EVT_WDF_REQUEST_COMPLETION_ROUTINE) +// _IRQL_requires_same_ + VOID + EVT_WDF_REQUEST_COMPLETION_ROUTINE( + _In_ + WDFREQUEST Request, + _In_ + WDFIOTARGET Target, + _In_ + PWDF_REQUEST_COMPLETION_PARAMS Params, + _In_ + WDFCONTEXT Context + ); + + typedef EVT_WDF_REQUEST_COMPLETION_ROUTINE *PFN_WDF_REQUEST_COMPLETION_ROUTINE; + +// line kdmf/1.11/wdfrequest.h, line 318. +typedef struct _WDF_REQUEST_REUSE_PARAMS { + // + // Size of this structure in bytes + // + ULONG Size; + + // + // Bit field combination of WDF_REQUEST_REUSE_Xxx values + // + ULONG Flags; + + // + // The new status of the request. + // + NTSTATUS Status; + + // + // New PIRP to be contained in the WDFREQUEST. Setting a new PIRP value + // is only valid for WDFREQUESTs created by WdfRequestCreateFromIrp where + // RequestFreesIrp == FALSE. No other WDFREQUESTs (presented by the + // I/O queue for instance) may have their IRPs changed. + // + PIRP NewIrp; + +} WDF_REQUEST_REUSE_PARAMS, *PWDF_REQUEST_REUSE_PARAMS; + +VOID +FORCEINLINE +WDF_REQUEST_REUSE_PARAMS_INIT( + /*_Out_*/ PWDF_REQUEST_REUSE_PARAMS Params, + /*_In_ */ ULONG Flags, + /*_In_ */ NTSTATUS Status + ) +{ + RtlZeroMemory(Params, sizeof(WDF_REQUEST_REUSE_PARAMS)); + + Params->Size = sizeof(WDF_REQUEST_REUSE_PARAMS); + Params->Flags = Flags; + Params->Status = Status; +} + +// Line 522 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +//WDFAPI +NTSTATUS +(*PFN_WDFREQUESTREUSE)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFREQUEST Request, + // _In_ + PWDF_REQUEST_REUSE_PARAMS ReuseParams + ); + +VOID WdfRequestComplete( + /*[in]*/ WDFREQUEST Request, + /*[in]*/ NTSTATUS Status +) +{ +} + +//_IRQL_requires_max_(DISPATCH_LEVEL) +NTSTATUS +FORCEINLINE +WdfRequestReuse( + //_In_ + WDFREQUEST Request, + //_In_ + PWDF_REQUEST_REUSE_PARAMS ReuseParams + ) +{ + // return ((PFN_WDFREQUESTREUSE) WdfFunctions[WdfRequestReuseTableIndex])(WdfDriverGlobals, Request, ReuseParams); + SLAyer_nondetT(NTSTATUS); +} + +// +// WDF Function: WdfRequestCreate +// +/* typedef */ +/* _Must_inspect_result_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +/* WDFAPI */ +/* NTSTATUS */ +/* (*PFN_WDFREQUESTCREATE)( */ +/* _In_ */ +/* PWDF_DRIVER_GLOBALS DriverGlobals, */ +/* _In_opt_ */ +/* PWDF_OBJECT_ATTRIBUTES RequestAttributes, */ +/* _In_opt_ */ +/* WDFIOTARGET IoTarget, */ +/* _Out_ */ +/* WDFREQUEST* Request */ +/* ); */ + +/* _Must_inspect_result_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +NTSTATUS +FORCEINLINE +WdfRequestCreate( + _In_opt_ + PWDF_OBJECT_ATTRIBUTES RequestAttributes, + _In_opt_ + WDFIOTARGET IoTarget, + _Out_ + WDFREQUEST* Request + ) +{ +/* return ((PFN_WDFREQUESTCREATE) WdfFunctions[WdfRequestCreateTableIndex])(WdfDriverGlobals, RequestAttributes, IoTarget, Request); */ + int x; + if (x) { + WDFREQUEST req = (WDFREQUEST)_SLAyer_malloc(sizeof(SLAyer_WDFOBJECT)); + req->typ = SLAyerWdfRequest; + req->Context = + (RequestAttributes == WDF_NO_OBJECT_ATTRIBUTES) ? NULL : + (*(RequestAttributes->MkContext))() ; + *Request = req; + return STATUS_SUCCESS; + } else { + return STATUS_UNSUCCESSFUL; + } +} + +typedef VOID (*PINTERFACE_REFERENCE)(PVOID Context); +typedef VOID (*PINTERFACE_DEREFERENCE)(PVOID Context); + +typedef struct _INTERFACE { + unsigned int Size; + unsigned int Version; + void * Context; + PINTERFACE_REFERENCE InterfaceReference; + PINTERFACE_DEREFERENCE InterfaceDereference; +} INTERFACE, *PINTERFACE; + +VOID WdfRequestCompleteWithInformation( + WDFREQUEST Request, + NTSTATUS Status, + ULONG_PTR Information +) +{} + +// Line 370 +typedef struct _WDF_REQUEST_SEND_OPTIONS { + // + // Size of the structure in bytes + // + ULONG Size; + + // + // Bit field combination of values from the WDF_REQUEST_SEND_OPTIONS_FLAGS + // enumeration + // + ULONG Flags; + + // + // Valid when WDF_REQUEST_SEND_OPTION_TIMEOUT is set + // + LONGLONG Timeout; + +} WDF_REQUEST_SEND_OPTIONS, *PWDF_REQUEST_SEND_OPTIONS; + +VOID +FORCEINLINE +WDF_REQUEST_SEND_OPTIONS_INIT( + _Out_ PWDF_REQUEST_SEND_OPTIONS Options, + _In_ ULONG Flags + ) +{ + RtlZeroMemory(Options, sizeof(WDF_REQUEST_SEND_OPTIONS)); + Options->Size = sizeof(WDF_REQUEST_SEND_OPTIONS); + Options->Flags = Flags; +} + +// 1.11, line 593 +//_IRQL_requires_max_(DISPATCH_LEVEL) +VOID +FORCEINLINE +WdfRequestFormatRequestUsingCurrentType( + _In_ + WDFREQUEST Request + ) +{ + // ((PFN_WDFREQUESTFORMATREQUESTUSINGCURRENTTYPE) WdfFunctions[WdfRequestFormatRequestUsingCurrentTypeTableIndex])(WdfDriverGlobals, Request); +} + +// Line 636 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +// _When_(Options->Flags & WDF_REQUEST_SEND_OPTION_SYNCHRONOUS == 0, _Must_inspect_result_) +WDFAPI +BOOLEAN +(*PFN_WDFREQUESTSEND)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFREQUEST Request, + // _In_ + WDFIOTARGET Target, + // _In_opt_ + PWDF_REQUEST_SEND_OPTIONS Options + ); + +/* Reimplementing. THe function WdfRequestSend calls this function, + * but the WDF implements this function in some unknown array. -- KK + * #PS637 + */ +// _IRQL_requires_max_(DISPATCH_LEVEL) +// _When_(Options->Flags & WDF_REQUEST_SEND_OPTION_SYNCHRONOUS == 0, _Must_inspect_result_) +BOOLEAN +FORCEINLINE +WdfRequestSend( + // _In_ + WDFREQUEST Request, + // _In_ + WDFIOTARGET Target, + // _In_opt_ + PWDF_REQUEST_SEND_OPTIONS Options + ) +{ + // return ((PFN_WDFREQUESTSEND) WdfFunctions[WdfRequestSendTableIndex])(WdfDriverGlobals, Request, Target, Options); + BOOLEAN b; + return b; +} + +// line 671 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFREQUESTGETSTATUS)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFREQUEST Request + ); + +/* Reimplementing. The function WdfRequestGetStatus calls this + * function, but the WDF implements this function in some unknown + * array. --KK #PS637 + */ +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +NTSTATUS +FORCEINLINE +WdfRequestGetStatus( + // _In_ + WDFREQUEST Request + ) +{ + // return ((PFN_WDFREQUESTGETSTATUS) WdfFunctions[WdfRequestGetStatusTableIndex])(WdfDriverGlobals, Request); + NTSTATUS status; + return status; +} + +// Line 864 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +VOID +(*PFN_WDFREQUESTSETCOMPLETIONROUTINE)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFREQUEST Request, + //_In_opt_ + PFN_WDF_REQUEST_COMPLETION_ROUTINE CompletionRoutine, + //_In_opt_ __drv_aliasesMem + WDFCONTEXT CompletionContext + ); + +/* Reimplementing this. The function WdfRequestSetCompletionRoutine + * needs this function, but WDF implements it using some unknown array. + * -- KK #PS637 + */ +//_IRQL_requires_max_(DISPATCH_LEVEL) +VOID +FORCEINLINE +WdfRequestSetCompletionRoutine( + //_In_ + WDFREQUEST Request, + //_In_opt_ + PFN_WDF_REQUEST_COMPLETION_ROUTINE CompletionRoutine, + //_In_opt_ __drv_aliasesMem + WDFCONTEXT CompletionContext + ) +{ + // ((PFN_WDFREQUESTSETCOMPLETIONROUTINE) WdfFunctions[WdfRequestSetCompletionRoutineTableIndex])(WdfDriverGlobals, Request, CompletionRoutine, CompletionContext); +} + +/****************************************************************************** + * File: wdfiotarget.h + ******************************************************************************/ + +// Copied from line 69 + +typedef +//_Function_class_(EVT_WDF_IO_TARGET_QUERY_REMOVE) +//_IRQL_requires_same_ +//_IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_IO_TARGET_QUERY_REMOVE( + _In_ + WDFIOTARGET IoTarget + ); + +typedef EVT_WDF_IO_TARGET_QUERY_REMOVE *PFN_WDF_IO_TARGET_QUERY_REMOVE; + +typedef +//_Function_class_(EVT_WDF_IO_TARGET_REMOVE_CANCELED) +//_IRQL_requires_same_ +//_IRQL_requires_max_(PASSIVE_LEVEL) +VOID +EVT_WDF_IO_TARGET_REMOVE_CANCELED( + _In_ + WDFIOTARGET IoTarget + ); + +typedef EVT_WDF_IO_TARGET_REMOVE_CANCELED *PFN_WDF_IO_TARGET_REMOVE_CANCELED; + +typedef +//_Function_class_(EVT_WDF_IO_TARGET_REMOVE_COMPLETE) +//_IRQL_requires_same_ +//_IRQL_requires_max_(PASSIVE_LEVEL) +VOID +EVT_WDF_IO_TARGET_REMOVE_COMPLETE( + _In_ + WDFIOTARGET IoTarget + ); + +typedef EVT_WDF_IO_TARGET_REMOVE_COMPLETE *PFN_WDF_IO_TARGET_REMOVE_COMPLETE; + +typedef enum _WDF_IO_TARGET_OPEN_TYPE { + WdfIoTargetOpenUndefined = 0, + WdfIoTargetOpenUseExistingDevice = 1, + WdfIoTargetOpenByName = 2, + WdfIoTargetOpenReopen = 3, +} WDF_IO_TARGET_OPEN_TYPE; + +// Patch: remove most of the struct (not needed in CromData_trace). +typedef struct _WDF_IO_TARGET_OPEN_PARAMS { + // + // Size of this structure in bytes + // + ULONG Size; + +/* // */ +/* // Indicates which fields of this structure are going to be used in */ +/* // creating the WDFIOTARGET. */ +/* // */ + WDF_IO_TARGET_OPEN_TYPE Type; + +/* // */ +/* // Notification when the target is being queried for removal. */ +/* // If !NT_SUCCESS is returned, the query will fail and the target will */ +/* // remain opened. */ +/* // */ + PFN_WDF_IO_TARGET_QUERY_REMOVE EvtIoTargetQueryRemove; + +/* // */ +/* // The previous query remove has been canceled and the target can now be */ +/* // reopened. */ +/* // */ + PFN_WDF_IO_TARGET_REMOVE_CANCELED EvtIoTargetRemoveCanceled; + +/* // */ +/* // The query remove has succeeded and the target is now removed from the */ +/* // system. */ +/* // */ + PFN_WDF_IO_TARGET_REMOVE_COMPLETE EvtIoTargetRemoveComplete; + +/* // ========== WdfIoTargetOpenUseExistingDevice begin ========== */ +/* // */ +/* // The device object to send requests to */ +/* // */ +/* PDEVICE_OBJECT TargetDeviceObject; */ + +/* // */ +/* // File object representing the TargetDeviceObject. The PFILE_OBJECT will */ +/* // be passed as a parameter in all requests sent to the resulting */ +/* // WDFIOTARGET. */ +/* // */ +/* PFILE_OBJECT TargetFileObject; */ +/* // ========== WdfIoTargetOpenUseExistingDevice end ========== */ + +/* // ========== WdfIoTargetOpenByName begin ========== */ +/* // */ +/* // Name of the device to open. */ +/* // */ + UNICODE_STRING TargetDeviceName; + +/* // */ +/* // The access desired on the device being opened up, ie WDM FILE_XXX_ACCESS */ +/* // such as FILE_ANY_ACCESS, FILE_SPECIAL_ACCESS, FILE_READ_ACCESS, or */ +/* // FILE_WRITE_ACCESS or you can use values such as GENERIC_READ, */ +/* // GENERIC_WRITE, or GENERIC_ALL. */ +/* // */ + ACCESS_MASK DesiredAccess; + +/* // */ +/* // Share access desired on the target being opened, ie WDM FILE_SHARE_XXX */ +/* // values such as FILE_SHARE_READ, FILE_SHARE_WRITE, FILE_SHARE_DELETE. */ +/* // */ +/* // A zero value means exclusive access to the target. */ +/* // */ + ULONG ShareAccess; + +/* // */ +/* // File attributes, see ZwCreateFile in the DDK for a list of valid */ +/* // values and their meaning. */ +/* // */ +/* ULONG FileAttributes; */ + +/* // */ +/* // Create disposition, see ZwCreateFile in the DDK for a list of valid */ +/* // values and their meaning. */ +/* // */ + ULONG CreateDisposition; + +/* // */ +/* // Options for opening the device, see CreateOptions for ZwCreateFile in the */ +/* // DDK for a list of valid values and their meaning. */ +/* // */ + ULONG CreateOptions; + +/* PVOID EaBuffer; */ + +/* ULONG EaBufferLength; */ + +/* PLONGLONG AllocationSize; */ + +/* // ========== WdfIoTargetOpenByName end ========== */ + +/* // */ +/* // On return for a create by name, this will contain one of the following */ +/* // values: FILE_CREATED, FILE_OPENED, FILE_OVERWRITTEN, FILE_SUPERSEDED, */ +/* // FILE_EXISTS, FILE_DOES_NOT_EXIST */ +/* // */ +/* ULONG FileInformation; */ + +} WDF_IO_TARGET_OPEN_PARAMS, *PWDF_IO_TARGET_OPEN_PARAMS; + +// Copied frol line 222 +VOID +FORCEINLINE +WDF_IO_TARGET_OPEN_PARAMS_INIT_CREATE_BY_NAME( + /*_Out_*/ PWDF_IO_TARGET_OPEN_PARAMS Params, + /*_In_ */ PCUNICODE_STRING TargetDeviceName, + /*_In_ */ ACCESS_MASK DesiredAccess + ) +{ + RtlZeroMemory(Params, sizeof(WDF_IO_TARGET_OPEN_PARAMS)); + + Params->Size = sizeof(WDF_IO_TARGET_OPEN_PARAMS); + Params->Type = WdfIoTargetOpenByName; + + RtlCopyMemory(&Params->TargetDeviceName, + TargetDeviceName, + sizeof(UNICODE_STRING)); + Params->DesiredAccess = DesiredAccess; + Params->CreateOptions = FILE_NON_DIRECTORY_FILE; +} + +VOID +FORCEINLINE +WDF_IO_TARGET_OPEN_PARAMS_INIT_OPEN_BY_NAME( + /*_Out_*/ PWDF_IO_TARGET_OPEN_PARAMS Params, + /*_In_*/ PCUNICODE_STRING TargetDeviceName, + /*_In_*/ ACCESS_MASK DesiredAccess + ) +{ + WDF_IO_TARGET_OPEN_PARAMS_INIT_CREATE_BY_NAME(Params, + TargetDeviceName, + DesiredAccess); + Params->CreateDisposition = FILE_OPEN; +} + +VOID +FORCEINLINE +WDF_IO_TARGET_OPEN_PARAMS_INIT_REOPEN( + /*_Out_*/ PWDF_IO_TARGET_OPEN_PARAMS Params + ) +{ + RtlZeroMemory(Params, sizeof(WDF_IO_TARGET_OPEN_PARAMS)); + + Params->Size = sizeof(WDF_IO_TARGET_OPEN_PARAMS); + Params->Type = WdfIoTargetOpenReopen; +} + +typedef struct _WDFMEMORY_OFFSET { + // + // Offset into the WDFMEMORY that the operation should start at. + // + size_t BufferOffset; + + // + // Number of bytes that the operation should access. If 0, the entire + // length of the WDFMEMORY buffer will be used in the operation or ignored + // depending on the API. + // + size_t BufferLength; + +} WDFMEMORY_OFFSET, *PWDFMEMORY_OFFSET; + +// line 306 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFIOTARGETOPEN)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFIOTARGET IoTarget, + // _In_ + PWDF_IO_TARGET_OPEN_PARAMS OpenParams + ); +/* Reimplementing. The function WdfIoTargetOpen calls this function, but + * this function is implemented by the WDF in some unknown array. --KK + * #PS637 + */ +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfIoTargetOpen( + // _In_ + WDFIOTARGET IoTarget, + // _In_ + PWDF_IO_TARGET_OPEN_PARAMS OpenParams + ) +{ + // return ((PFN_WDFIOTARGETOPEN) WdfFunctions[WdfIoTargetOpenTableIndex])(WdfDriverGlobals, IoTarget, OpenParams); + NTSTATUS status; + return status; +} + +// Line 337 +typedef +//_IRQL_requires_max_(PASSIVE_LEVEL) +WDFAPI +VOID +(*PFN_WDFIOTARGETCLOSEFORQUERYREMOVE)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFIOTARGET IoTarget + ); + +/* Reimplementing myself. This function is alled by + * WdfIoTargetCloseForQueryRemove, but the WDF implements this function + * using some unknown array. --KK #PS637 + */ +//_IRQL_requires_max_(PASSIVE_LEVEL) +VOID +FORCEINLINE +WdfIoTargetCloseForQueryRemove( + //_In_ + WDFIOTARGET IoTarget + ) +{ + //((PFN_WDFIOTARGETCLOSEFORQUERYREMOVE) WdfFunctions[WdfIoTargetCloseForQueryRemoveTableIndex])(WdfDriverGlobals, IoTarget); +} + +// line 904 +typedef +//_Must_inspect_result_ +//_IRQL_requires_max_(DISPATCH_LEVEL) +// WDFAPI +NTSTATUS +(*PFN_WDFIOTARGETFORMATREQUESTFORWRITE)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFIOTARGET IoTarget, + //_In_ + WDFREQUEST Request, + //_In_opt_ + WDFMEMORY InputBuffer, + //_In_opt_ + PWDFMEMORY_OFFSET InputBufferOffset, + //_In_opt_ + PLONGLONG DeviceOffset + ); + +/* Reimplementing this as a stub. THe function + * WdfIoTargetFormatRequestForWrite calls this, but it is defined in + * some unknown array. -- KK #PS637 + */ +//_Must_inspect_result_ +//_IRQL_requires_max_(DISPATCH_LEVEL) +NTSTATUS +FORCEINLINE +WdfIoTargetFormatRequestForWrite( + //_In_ + WDFIOTARGET IoTarget, + //_In_ + WDFREQUEST Request, + //_In_opt_ + WDFMEMORY InputBuffer, + //_In_opt_ + PWDFMEMORY_OFFSET InputBufferOffset, + //_In_opt_ + PLONGLONG DeviceOffset + ) +{ + /* return ((PFN_WDFIOTARGETFORMATREQUESTFORWRITE) WdfFunctions[WdfIoTargetFormatRequestForWriteTableIndex] +)(WdfDriverGlobals, IoTarget, Request, InputBuffer, InputBufferOffset, DeviceOffset); */ NTSTATUS status; + return status; +} + +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFIOTARGETALLOCANDQUERYTARGETPROPERTY)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFIOTARGET IoTarget, + // _In_ + DEVICE_REGISTRY_PROPERTY DeviceProperty, + // _In_ + // _Strict_type_match_ + POOL_TYPE PoolType, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES PropertyMemoryAttributes, + // _Out_ + WDFMEMORY* PropertyMemory + ); + +PFN_WDFIOTARGETALLOCANDQUERYTARGETPROPERTY +WdfIoTargetAllocAndQueryTargetPropertyTableIndex( + WDFIOTARGET IoTarget, + DEVICE_REGISTRY_PROPERTY DeviceProperty, + POOL_TYPE PoolType, + PWDF_OBJECT_ATTRIBUTES PropertyMemoryAttributes, + WDFMEMORY* PropertyMemory + ) +{ + return NULL; +} + +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +// PS #640 Consider generalizing return values +NTSTATUS +FORCEINLINE +WdfIoTargetAllocAndQueryTargetProperty( + // _In_ + WDFIOTARGET IoTarget, + // _In_ + DEVICE_REGISTRY_PROPERTY DeviceProperty, + // _In_ + // _Strict_type_match_ + POOL_TYPE PoolType, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES PropertyMemoryAttributes, + // _Out_ + WDFMEMORY* PropertyMemory + ) +{ + // return ((PFN_WDFIOTARGETALLOCANDQUERYTARGETPROPERTY) WdfFunctions[WdfIoTargetAllocAndQueryTargetPropertyTableIndex])(WdfDriverGlobals, IoTarget, DeviceProperty, PoolType, PropertyMemoryAttributes, PropertyMemory); + SLAyer_nondetT(NTSTATUS); +} + +// line 667 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +PDEVICE_OBJECT +(*PFN_WDFIOTARGETWDMGETTARGETDEVICEOBJECT)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFIOTARGET IoTarget + ); +/* reimplementing myself. this function is called by + * WdfIoTargetWdmGetTargetDeviceObject, but the WDF implements this + * function using an unknown array. --KK #PS637 + */ +//_IRQL_requires_max_(DISPATCH_LEVEL) +PDEVICE_OBJECT +FORCEINLINE +WdfIoTargetWdmGetTargetDeviceObject( + //_In_ + WDFIOTARGET IoTarget + ) +{ + //return ((PFN_WDFIOTARGETWDMGETTARGETDEVICEOBJECT) WdfFunctions[WdfIoTargetWdmGetTargetDeviceObjectTableIndex])(WdfDriverGlobals, IoTarget); + return NULL; +} + +// line 814 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFIOTARGETFORMATREQUESTFORREAD)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFIOTARGET IoTarget, + // _In_ + WDFREQUEST Request, + // _In_opt_ + WDFMEMORY OutputBuffer, + // _In_opt_ + PWDFMEMORY_OFFSET OutputBufferOffset, + // _In_opt_ + PLONGLONG DeviceOffset + ); + +/* reimplementing myself. This function is called from + * WdfIotargetFormatRequestForRead, but the WDF implements this function + * using an unknown array. --KK #PS637 + */ +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +NTSTATUS +FORCEINLINE +WdfIoTargetFormatRequestForRead( + // _In_ + WDFIOTARGET IoTarget, + // _In_ + WDFREQUEST Request, + // _In_opt_ + WDFMEMORY OutputBuffer, + // _In_opt_ + PWDFMEMORY_OFFSET OutputBufferOffset, + // _In_opt_ + PLONGLONG DeviceOffset + ) +{ + // return ((PFN_WDFIOTARGETFORMATREQUESTFORREAD) WdfFunctions[WdfIoTargetFormatRequestForReadTableIndex])(WdfDriverGlobals, IoTarget, Request, OutputBuffer, OutputBufferOffset, DeviceOffset); + NTSTATUS status; + return status; +} + +/****************************************************************************** + * File: wdfio.h + ******************************************************************************/ + +typedef enum _WDF_IO_QUEUE_DISPATCH_TYPE { + WdfIoQueueDispatchInvalid = 0, + WdfIoQueueDispatchSequential, + WdfIoQueueDispatchParallel, + WdfIoQueueDispatchManual, + WdfIoQueueDispatchMax, +} WDF_IO_QUEUE_DISPATCH_TYPE; + +// +// Event callback definitions +// + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_DEFAULT) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_DEFAULT( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request + ); + +typedef EVT_WDF_IO_QUEUE_IO_DEFAULT *PFN_WDF_IO_QUEUE_IO_DEFAULT; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_STOP) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_STOP( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request, +/* _In_ */ + ULONG ActionFlags + ); + +typedef EVT_WDF_IO_QUEUE_IO_STOP *PFN_WDF_IO_QUEUE_IO_STOP; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_RESUME) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_RESUME( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request + ); + +typedef EVT_WDF_IO_QUEUE_IO_RESUME *PFN_WDF_IO_QUEUE_IO_RESUME; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_READ) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_READ( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request, +/* _In_ */ + size_t Length + ); + +typedef EVT_WDF_IO_QUEUE_IO_READ *PFN_WDF_IO_QUEUE_IO_READ; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_WRITE) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_WRITE( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request, +/* _In_ */ + size_t Length + ); + +typedef EVT_WDF_IO_QUEUE_IO_WRITE *PFN_WDF_IO_QUEUE_IO_WRITE; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_DEVICE_CONTROL) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_DEVICE_CONTROL( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request, +/* _In_ */ + size_t OutputBufferLength, +/* _In_ */ + size_t InputBufferLength, +/* _In_ */ + ULONG IoControlCode + ); + +typedef EVT_WDF_IO_QUEUE_IO_DEVICE_CONTROL *PFN_WDF_IO_QUEUE_IO_DEVICE_CONTROL; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_INTERNAL_DEVICE_CONTROL) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_INTERNAL_DEVICE_CONTROL( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request, +/* _In_ */ + size_t OutputBufferLength, +/* _In_ */ + size_t InputBufferLength, +/* _In_ */ + ULONG IoControlCode + ); + +typedef EVT_WDF_IO_QUEUE_IO_INTERNAL_DEVICE_CONTROL *PFN_WDF_IO_QUEUE_IO_INTERNAL_DEVICE_CONTROL; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_IO_CANCELED_ON_QUEUE) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_IO_CANCELED_ON_QUEUE( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFREQUEST Request + ); + +typedef EVT_WDF_IO_QUEUE_IO_CANCELED_ON_QUEUE *PFN_WDF_IO_QUEUE_IO_CANCELED_ON_QUEUE; + +typedef +/* _Function_class_(EVT_WDF_IO_QUEUE_STATE) */ +/* _IRQL_requires_same_ */ +/* _IRQL_requires_max_(DISPATCH_LEVEL) */ +VOID +EVT_WDF_IO_QUEUE_STATE( +/* _In_ */ + WDFQUEUE Queue, +/* _In_ */ + WDFCONTEXT Context + ); + +typedef EVT_WDF_IO_QUEUE_STATE *PFN_WDF_IO_QUEUE_STATE; + +// Patch: remove most of the struct (not needed by CromData_trace). +// And SDV is meant to be able to find fptrs anyway. +typedef struct _WDF_IO_QUEUE_CONFIG { + + ULONG Size; + + WDF_IO_QUEUE_DISPATCH_TYPE DispatchType; + +/* WDF_TRI_STATE PowerManaged; */ + +/* BOOLEAN AllowZeroLengthRequests; */ + +/* BOOLEAN DefaultQueue; */ + + PFN_WDF_IO_QUEUE_IO_DEFAULT EvtIoDefault; + + PFN_WDF_IO_QUEUE_IO_READ EvtIoRead; + + PFN_WDF_IO_QUEUE_IO_WRITE EvtIoWrite; + + // PFN_WDF_IO_QUEUE_IO_DEVICE_CONTROL + void* EvtIoDeviceControl; + +/* PFN_WDF_IO_QUEUE_IO_INTERNAL_DEVICE_CONTROL EvtIoInternalDeviceControl; */ + + PFN_WDF_IO_QUEUE_IO_STOP EvtIoStop; + +/* PFN_WDF_IO_QUEUE_IO_RESUME EvtIoResume; */ + +/* PFN_WDF_IO_QUEUE_IO_CANCELED_ON_QUEUE EvtIoCanceledOnQueue; */ + + union { + struct { + ULONG NumberOfPresentedRequests; + } Parallel; + } Settings; + +} WDF_IO_QUEUE_CONFIG, *PWDF_IO_QUEUE_CONFIG; + +VOID +FORCEINLINE +WDF_IO_QUEUE_CONFIG_INIT_DEFAULT_QUEUE( + __out PWDF_IO_QUEUE_CONFIG Config, + __in WDF_IO_QUEUE_DISPATCH_TYPE DispatchType + ) +{ + // Patch + //RtlZeroMemory(Config, sizeof(WDF_IO_QUEUE_CONFIG)); + + Config->Size = sizeof(WDF_IO_QUEUE_CONFIG); +/* Config->PowerManaged = WdfUseDefault; */ +/* Config->DefaultQueue = TRUE; */ + Config->DispatchType = DispatchType; + if (Config->DispatchType == WdfIoQueueDispatchParallel) { + Config->Settings.Parallel.NumberOfPresentedRequests = (ULONG)-1; + } +} + +// PS #640 Consider generalizing return values +NTSTATUS WdfIoQueueCreate( + IN WDFDEVICE Device, + IN PWDF_IO_QUEUE_CONFIG Config, + IN PWDF_OBJECT_ATTRIBUTES QueueAttributes, + OUT WDFQUEUE *Queue +) +{ + NTSTATUS status; + int nondet; + + if (nondet) { + WDFQUEUE q; + q = (WDFQUEUE)_SLAyer_malloc(sizeof(SLAyer_WDFOBJECT)); + // Might need to use [Config], [QueueAttributes]. + q->typ = SLAyerWdfQueue; + q->Parent = Device; + q->typQueue.Device = Device; + // Device --> q + Device->typDevice.Queue = q; + // returns + if (NULL != Queue) { *Queue = q; } + status = STATUS_SUCCESS; + } else { + status = STATUS_UNSUCCESSFUL; + } + return status; +} + +// SLAyer: implemented in specific harnesses. +PDEVICE_OBJECT WdfDeviceWdmGetPhysicalDevice(WDFDEVICE Device); +PDEVICE_OBJECT WdfDeviceWdmGetAttachedDevice(WDFDEVICE Device); + +WDFDEVICE WdfIoQueueGetDevice(IN WDFQUEUE Queue) +{ + return Queue->typQueue.Device; +} + + +/****************************************************************************** + * File: wdffdo.h + ******************************************************************************/ + +VOID WdfFdoInitSetFilter(PWDFDEVICE_INIT DeviceInit) +{ +} + +VOID +WdfFdoLockStaticChildListForIteration(WDFDEVICE Fdo) +{ +} + +VOID +WdfFdoUnlockStaticChildListFromIteration(WDFDEVICE Fdo) +{ +} + +/* + SLAyer: We're assuming that SL_Device_one is the Fdo, and + SL_Device_two is the Child Pdo. So, AddStatic just skips, + RetrieveNext returns SL_Device_two. + */ +NTSTATUS WdfFdoAddStaticChild(WDFDEVICE Fdo, WDFDEVICE Child) +{ + int x; + if (x) { return STATUS_SUCCESS; } + else { return STATUS_UNSUCCESSFUL; } +} + +WDFDEVICE WdfFdoRetrieveNextStaticChild(WDFDEVICE Fdo, WDFDEVICE PreviousChild, ULONG Flags) +{ + return SL_Device_two; +} + +VOID +WdfFdoInitSetDefaultChildListConfig( +PWDFDEVICE_INIT DeviceInit, +PWDF_CHILD_LIST_CONFIG config, +PWDF_OBJECT_ATTRIBUTES DefaultChildListAttributes) +{ +} + +// PS #644 DeviceInit lifetime +// PS #640 Consider generalizing return values +PWDFDEVICE_INIT WdfPdoInitAllocate(WDFDEVICE ParentDevice) +{ + return &SL_WdfDeviceInit; +} + +// PS #640 Consider generalizing return values +NTSTATUS WdfPdoMarkMissing(WDFDEVICE Device) +{ + SLAyer_nondetT(NTSTATUS); +} + +VOID WdfPdoRequestEject(WDFDEVICE Device) +{ +} + +VOID WdfRequestSetInformation( + /*in*/ WDFREQUEST Request, + /*in*/ ULONG_PTR Information +) +{ +} + +NTSTATUS +WdfPdoInitAssignDeviceID(PWDFDEVICE_INIT DeviceInit, PCUNICODE_STRING DeviceID) +{ + SLAyer_nondetT(NTSTATUS); +} + +NTSTATUS +WdfPdoInitAddHardwareID(PWDFDEVICE_INIT DeviceInit, PCUNICODE_STRING HardwareID) +{ + SLAyer_nondetT(NTSTATUS); +} + +NTSTATUS +WdfPdoInitAddCompatibleID(PWDFDEVICE_INIT DeviceInit, PCUNICODE_STRING CompatibleID) +{ + SLAyer_nondetT(NTSTATUS); +} + +NTSTATUS +WdfPdoInitAssignInstanceID(PWDFDEVICE_INIT DeviceInit, PCUNICODE_STRING InstanceID) +{ + SLAyer_nondetT(NTSTATUS); +} + +NTSTATUS +WdfPdoInitAddDeviceText(PWDFDEVICE_INIT DeviceInit, PCUNICODE_STRING Desc, PCUNICODE_STRING Loc, int LocalId) +{ + SLAyer_nondetT(NTSTATUS); +} + +VOID +WdfPdoInitSetDefaultLocale(PWDFDEVICE_INIT DeviceInit, ULONG locale) {} + +WDFCHILDLIST +WdfFdoGetDefaultChildList(WDFDEVICE Fdo) {} + +//line 188 +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfFdoInitQueryProperty( + // _In_ + PWDFDEVICE_INIT DeviceInit, + // _In_ + DEVICE_REGISTRY_PROPERTY DeviceProperty, + // _In_ + ULONG BufferLength, + // _Out_writes_bytes_all_opt_(BufferLength) + PVOID PropertyBuffer, + // _Out_ + PULONG ResultLength + ) +{ + // return ((PFN_WDFFDOINITQUERYPROPERTY) WdfFunctions[WdfFdoInitQueryPropertyTableIndex])(WdfDriverGlobals, DeviceInit, DeviceProperty, BufferLength, PropertyBuffer, ResultLength); + NTSTATUS status; + return status; +} + +// line 339 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFFDOQUERYFORINTERFACE)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFDEVICE Fdo, + // _In_ + LPCGUID InterfaceType, + // _Out_ + PINTERFACE Interface, + // _In_ + USHORT Size, + // _In_ + USHORT Version, + // _In_opt_ + PVOID InterfaceSpecificData + ); + +/* PS#637 -- KK */ +// _Must_inspect_result_ +//_IRQL_requires_max_(PASSIVE_LEVEL) +NTSTATUS +FORCEINLINE +WdfFdoQueryForInterface( + // _In_ + WDFDEVICE Fdo, + // _In_ + LPCGUID InterfaceType, + // _Out_ + PINTERFACE Interface, + // _In_ + USHORT Size, + // _In_ + USHORT Version, + // _In_opt_ + PVOID InterfaceSpecificData + ) +{ + // return ((PFN_WDFFDOQUERYFORINTERFACE) WdfFunctions[WdfFdoQueryForInterfaceTableIndex])(WdfDriverGlobals, Fdo, InterfaceType, Interface, Size, Version, InterfaceSpecificData); + NTSTATUS status; + return status; +} + +/****************************************************************************** + * File: wdfwmi.h + ******************************************************************************/ + //copied from line 30 + typedef enum _WDF_WMI_PROVIDER_CONTROL { + WdfWmiControlInvalid = 0, + WdfWmiEventControl, + WdfWmiInstanceControl, +} WDF_WMI_PROVIDER_CONTROL; + +// copied from line 54 +typedef enum _WDF_WMI_PROVIDER_FLAGS { + WdfWmiProviderEventOnly = 0x0001, + WdfWmiProviderExpensive = 0x0002, + WdfWmiProviderTracing = 0x0004, + WdfWmiProviderValidFlags = WdfWmiProviderEventOnly | WdfWmiProviderExpensive | WdfWmiProviderTracing, +} WDF_WMI_PROVIDER_FLAGS; + +//copied from line 57 + +typedef +NTSTATUS +(*PFN_WDF_WMI_INSTANCE_QUERY_INSTANCE)( + IN WDFWMIINSTANCE WmiInstance, + IN ULONG OutBufferSize, + IN PVOID OutBuffer, + OUT PULONG BufferUsed + ); + +typedef +NTSTATUS +(*PFN_WDF_WMI_INSTANCE_SET_INSTANCE)( + IN WDFWMIINSTANCE WmiInstance, + IN ULONG InBufferSize, + IN PVOID InBuffer + ); + +typedef +NTSTATUS +(*PFN_WDF_WMI_INSTANCE_SET_ITEM)( + IN WDFWMIINSTANCE WmiInstance, + IN ULONG DataItemId, + IN ULONG InBufferSize, + IN PVOID InBuffer + ); + +typedef +NTSTATUS +(*PFN_WDF_WMI_INSTANCE_EXECUTE_METHOD)( + IN WDFWMIINSTANCE WmiInstance, + IN ULONG MethodId, + IN ULONG InBufferSize, + IN ULONG OutBufferSize, + IN OUT PVOID Buffer, + OUT PULONG BufferUsed + ); + + //copied from wdf/inc/kmdf/1.7/wdfwmi.h, line 68 + + typedef +NTSTATUS +(EVT_WDF_WMI_INSTANCE_QUERY_INSTANCE)( + IN WDFWMIINSTANCE WmiInstance, + IN ULONG OutBufferSize, + IN PVOID OutBuffer, + OUT PULONG BufferUsed + ); + + typedef +NTSTATUS +(EVT_WDF_WMI_INSTANCE_SET_INSTANCE)( + IN WDFWMIINSTANCE WmiInstance, + IN ULONG InBufferSize, + IN PVOID InBuffer + ); + + typedef +NTSTATUS +(EVT_WDF_WMI_INSTANCE_SET_ITEM)( + IN WDFWMIINSTANCE WmiInstance, + IN ULONG DataItemId, + IN ULONG InBufferSize, + IN PVOID InBuffer + ); + + //copied from line 94 + + typedef +NTSTATUS +(*PFN_WDF_WMI_PROVIDER_FUNCTION_CONTROL)( + IN WDFWMIPROVIDER WmiProvider, + IN WDF_WMI_PROVIDER_CONTROL Control, + IN BOOLEAN Enable + ); + + //copied from line 102 + +typedef struct _WDF_WMI_PROVIDER_CONFIG { + // + // Size of this structure in bytes + // + ULONG Size; + + // + // The GUID being registered + // + GUID Guid; + + // + // Combination of values from the enum WDF_WMI_PROVIDER_FLAGS + // + ULONG Flags; + + // + // Minimum expected buffer size for query and set instance requests. + // Ignored if WdfWmiProviderEventOnly is set in Flags. + // + ULONG MinInstanceBufferSize; + + // + // Callback when caller is opening a provider which ha been marked as + // expensive or when a caller is interested in events. + // + PFN_WDF_WMI_PROVIDER_FUNCTION_CONTROL EvtWmiProviderFunctionControl; + +} WDF_WMI_PROVIDER_CONFIG, *PWDF_WMI_PROVIDER_CONFIG; + +// copied from line 115 +typedef +NTSTATUS +EVT_WDF_WMI_INSTANCE_EXECUTE_METHOD( + _In_ + WDFWMIINSTANCE WmiInstance, + _In_ + ULONG MethodId, + _In_ + ULONG InBufferSize, + _In_ + ULONG OutBufferSize, + //_When_(InBufferSize >= OutBufferSize, _Inout_updates_bytes_(InBufferSize)) + //_When_(InBufferSize < OutBufferSize, _Inout_updates_bytes_(OutBufferSize)) + PVOID Buffer, + _Out_ + PULONG BufferUsed + ); + +typedef EVT_WDF_WMI_INSTANCE_EXECUTE_METHOD *PFN_WDF_WMI_INSTANCE_EXECUTE_METHOD; + +//copied from line 145 + +typedef struct _WDF_WMI_INSTANCE_CONFIG { + // + // Size of the structure in bytes + // + ULONG Size; + + // + // Optional parameter. If NULL, ProviderConfig must be set to a valid pointer + // value. If specified, indicates the provider to create an instance for. + // + WDFWMIPROVIDER Provider; + + // + // Optional parameter. If NULL, Provider must be set to a valid handle + // value. If specifeid, indicates the configuration for a provider to be + // created and for this instance to be associated with. + // + PWDF_WMI_PROVIDER_CONFIG ProviderConfig; + + // + // If the Provider is configured as read only and this field is set to TRUE, + // the EvtWmiInstanceQueryInstance is ignored and WDF will blindly copy the + // context associated with this instance (using RtlCopyMemory, with no locks + // held) into the query buffer. + // + BOOLEAN UseContextForQuery; + + // + // If TRUE, the instance will be registered as well as created. + // + BOOLEAN Register; + + // + // Callback when caller wants to query the entire data item's buffer. + // + PFN_WDF_WMI_INSTANCE_QUERY_INSTANCE EvtWmiInstanceQueryInstance; + + // + // Callback when caller wants to set the entire data item's buffer. + // + PFN_WDF_WMI_INSTANCE_SET_INSTANCE EvtWmiInstanceSetInstance; + + // + // Callback when caller wants to set a single field in the data item's buffer + // + PFN_WDF_WMI_INSTANCE_SET_ITEM EvtWmiInstanceSetItem; + + // + // Callback when caller wants to execute a method on the data item. + // + PFN_WDF_WMI_INSTANCE_EXECUTE_METHOD EvtWmiInstanceExecuteMethod; + +} WDF_WMI_INSTANCE_CONFIG, *PWDF_WMI_INSTANCE_CONFIG; + +// SLayer: implemented in specific harnesses. +WDFDEVICE WdfWmiInstanceGetDevice( /* [in] */ WDFWMIINSTANCE WmiInstance); + +VOID WDF_WMI_PROVIDER_CONFIG_INIT( + _Out_ PWDF_WMI_PROVIDER_CONFIG Config, + _In_ const GUID *Guid +) +{ +} + +// PS #632 + #define WDF_PTR_ADD_OFFSET_TYPE(_ptr, _offset, _type) \ + (_ptr) + + #define WDF_PTR_ADD_OFFSET(_ptr, _offset) \ + WDF_PTR_ADD_OFFSET_TYPE(_ptr, _offset, PVOID) + +// Line 277 +NTSTATUS +FORCEINLINE +WDF_WMI_BUFFER_APPEND_STRING( + /*_Out_writes_bytes_(BufferLength)*/ PVOID Buffer, + /*_In_ */ ULONG BufferLength, + /*_In_ */ PCUNICODE_STRING String, + /*_Out_*/ PULONG RequiredSize + ) +{ + NTSTATUS status; + return status; + /* + NTSTATUS status; + return status; + // + // Compute the length of buffer we need to use. Upon error the caller can + // use this length to report the required length. On success, the caller + // can use this length to know how many bytes were written. + // + //RequiredSize = String->Length + sizeof(USHORT); + // + // UNICODE_STRING.Length is the length of the string in bytes, not characters + // + + // First check to see if there is enough space + // 1) to store the length of the string + // 2) to store the string itself + // + if (BufferLength < (String->Length + sizeof(USHORT))) { + // + // Not enough room in the string, report back how big a buffer is + // required. + // + return STATUS_BUFFER_TOO_SMALL; + } + + // + // Store the length of the string + // + *(USHORT *) Buffer = String->Length; + + // + // Copy the string to the buffer + // + RtlCopyMemory(WDF_PTR_ADD_OFFSET(Buffer, sizeof(USHORT)), + String->Buffer, + String->Length); + */ + //return STATUS_SUCCESS; +} + +VOID WDF_WMI_INSTANCE_CONFIG_INIT_PROVIDER_CONFIG( + _Out_ PWDF_WMI_INSTANCE_CONFIG Config, + _In_ PWDF_WMI_PROVIDER_CONFIG ProviderConfig +) +{ +} + +// PS #640 Consider generalizing return values +NTSTATUS WdfWmiInstanceCreate( + /*[in]*/ WDFDEVICE Device, + /*[in]*/ PWDF_WMI_INSTANCE_CONFIG InstanceConfig, + /*[in, optional]*/ PWDF_OBJECT_ATTRIBUTES InstanceAttributes, + /*[out, optional]*/ WDFWMIINSTANCE *Instance +) +{ + int nondet; + NTSTATUS status; + + if (nondet) { + WDFWMIINSTANCE w; + w = (WDFWMIINSTANCE)_SLAyer_malloc(sizeof(SLAyer_WDFOBJECT)); + w->Context = + (InstanceAttributes == WDF_NO_OBJECT_ATTRIBUTES) ? NULL : + (*(InstanceAttributes->MkContext))() ; + w->typ = SLAyerWdfWmiInstance; + w->Parent = Device; + w->typWmiInstance.Device = Device; + // Device --> w. We have space for two [w]s. + if (Device->typDevice.WmiInstance1 == NULL) { + Device->typDevice.WmiInstance1 = w; + } else if (Device->typDevice.WmiInstance2 == NULL) { + Device->typDevice.WmiInstance2 = w; + } else if (Device->typDevice.WmiInstance3 == NULL) { + Device->typDevice.WmiInstance3 = w; + } else { + // SLAyer: Need to return UNSUCCESSFUL and clean up mallocs. + } + // returns + if (NULL != Instance) { *Instance = w; } + status = STATUS_SUCCESS; + } else { + status = STATUS_UNSUCCESSFUL; + } + return status; +} + +WDFDEVICE WdfWmiInstanceGetDevice( /* [in] */ WDFWMIINSTANCE WmiInstance) +{ + return WmiInstance->typWmiInstance.Device; +} + +/****************************************************************************** + * File: wdfregistry.h + ******************************************************************************/ +NTSTATUS WdfRegistryQueryULong( + /*[in]*/ WDFKEY Key, + /*[in]*/ PCUNICODE_STRING ValueName, + /*[out]*/ PULONG Value +) +{ + SLAyer_nondetT(NTSTATUS); +} + +VOID WdfRegistryClose( + /* [in] */ WDFKEY Key +) +{ +} + +/****************************************************************************** + * File: wdfqueryinterface.h + ******************************************************************************/ +//copied from line 32 + +typedef +NTSTATUS +(EVT_WDF_DEVICE_PROCESS_QUERY_INTERFACE_REQUEST)( + IN WDFDEVICE Device, + IN LPGUID InterfaceType, + IN OUT PINTERFACE ExposedInterface, + IN OUT PVOID ExposedInterfaceSpecificData + ); + +typedef EVT_WDF_DEVICE_PROCESS_QUERY_INTERFACE_REQUEST *PFN_WDF_DEVICE_PROCESS_QUERY_INTERFACE_REQUEST; + + //copied from line 43 + + typedef struct _WDF_QUERY_INTERFACE_CONFIG { + // + // Size of this structure in bytes. + // + ULONG Size; + + // + // Interface to be returned to the caller. Optional if BehaviorType is set + // to WdfQueryInterfaceTypePassThrough or ImportInterface is set to TRUE. + // + PINTERFACE Interface; + + // + // The GUID identifying the interface + // + const GUID * InterfaceType; + + // + // Valid only for PDOs. The framework will allocate a new request and + // forward it down the parent's device stack. + // + BOOLEAN SendQueryToParentStack; + + // + // Driver supplied callback which is called after some basic interface + // validation has been performed (size, version, and guid checking). This + // is an optional parameter and may be NULL unless ImportInterface is + // specified. + // + // If the callback returns !NT_SUCCESS, this error will be returned to the + // caller and the query interface will fail. + // + // In this callback, the caller is free to modify the ExposedInterface in + // any manner of its choosing. For instance, the callback may change any + // field in the interface. The callback may also alloate a dynamic context + // to be associated with the interface; the InterfaceReference and + // InterfaceDereference functions may also be overridden. + // + // If ImportInterface is set to TRUE, then this is a required field and the + // callback must initialize the interface (the framework will leave the + // ExposedInterface buffer exactly as it received it) since the framework + // has no way of knowing which fields to fill in and which to leave alone. + // + PFN_WDF_DEVICE_PROCESS_QUERY_INTERFACE_REQUEST EvtDeviceProcessQueryInterfaceRequest; + + // + // If TRUE, the interface provided by the caller contains data that the + // driver is interested in. By setting to this field to TRUE, the + // EvtDeviceProcessQueryInterfaceRequest callback must initialize the + // ExposedInterface. + // + // If FALSE, the entire ExposedInterface is initialized through a memory + // copy before the EvtDeviceProcessQueryInterfaceRequest is called. + // + BOOLEAN ImportInterface; + +} WDF_QUERY_INTERFACE_CONFIG, *PWDF_QUERY_INTERFACE_CONFIG; + +VOID +FORCEINLINE +WdfDeviceInterfaceReferenceNoOp( + PVOID Context + ) +{ + UNREFERENCED_PARAMETER(Context); +} + +VOID +FORCEINLINE +WdfDeviceInterfaceDereferenceNoOp( + PVOID Context + ) +{ + UNREFERENCED_PARAMETER(Context); +} + +VOID WDF_QUERY_INTERFACE_CONFIG_INIT +( + PWDF_QUERY_INTERFACE_CONFIG InterfaceConfig, + PINTERFACE Inteface, + const GUID *InterfaceType, + PFN_WDF_DEVICE_PROCESS_QUERY_INTERFACE_REQUEST EvtDeviceProcessQueryInterfaceRequest) +{ +} + +NTSTATUS WdfDeviceAddQueryInterface(WDFDEVICE Device, + PWDF_QUERY_INTERFACE_CONFIG InterfaceConfig) +{ + SLAyer_nondetT(NTSTATUS); +} + +/****************************************************************************** + * File: wdfroletypes.h. + ******************************************************************************/ +typedef EVT_WDF_OBJECT_CONTEXT_CLEANUP EVT_WDF_DEVICE_CONTEXT_CLEANUP; + +/****************************************************************************** + * File: wudfwdm.h + ******************************************************************************/ +// Line 203 +#define CmResourceTypePort 1 // ResType_IO (0x0002) +#define CmResourceTypeInterrupt 2 // ResType_IRQ (0x0004) +#define CmResourceTypeMemory 3 // ResType_Mem (0x0001) + +/***************************************************************************** + * File: wmistr.h + ****************************************************************************/ + +/* KK -- Apparently this is wrong, LARGE_INTEGER is a structured type. + * See the implementation in shared/WTypesbase.h, I've copied it into + * this file. + */ +// DECLARE_HANDLE(LARGE_INTEGER); + +// Copied from line 56 +#define WNODE_FLAG_ALL_DATA 0x00000001 // set for WNODE_ALL_DATA +#define WNODE_FLAG_SINGLE_INSTANCE 0x00000002 // set for WNODE_SINGLE_INSTANCE +#define WNODE_FLAG_SINGLE_ITEM 0x00000004 // set for WNODE_SINGLE_ITEM +#define WNODE_FLAG_EVENT_ITEM 0x00000008 // set for WNODE_EVENT_ITEM + +#define WMIGUID_NOTIFICATION 0x0004 + +// Copied from line 144 +typedef struct _WNODE_HEADER +{ + ULONG BufferSize; // Size of entire buffer inclusive of this ULONG + ULONG ProviderId; // Provider Id of driver returning this buffer +/* union + { + //ULONG64 HistoricalContext; // Logger use + struct + { */ + ULONG Version; // Reserved +/* + ULONG Linkage; // Linkage field reserved for WMI + } DUMMYSTRUCTNAME; + } DUMMYUNIONNAME; + union + { + ULONG CountLost; // Reserved + HANDLE KernelHandle; // Kernel handle for data block +*/ + LARGE_INTEGER TimeStamp; // Timestamp as returned in units of 100ns +/* + // since 1/1/1601 + } DUMMYUNIONNAME2; +*/ + GUID Guid; // Guid for data block returned with results +/* + ULONG ClientContext; +*/ + ULONG Flags; // Flags, see below +} WNODE_HEADER, *PWNODE_HEADER; + +typedef struct tagWNODE_SINGLE_INSTANCE +{ + struct _WNODE_HEADER WnodeHeader; + + // Offset from beginning of WNODE_SINGLE_INSTANCE + // to instance name. Use when + // WNODE_FLAG_STATIC_INSTANCE_NAMES is reset + // (Dynamic instance names) + ULONG OffsetInstanceName; + + // Instance index when + // WNODE_FLAG_STATIC_INSTANCE_NAME is set + ULONG InstanceIndex; // (Static Instance Names) + + ULONG DataBlockOffset; // offset from beginning of WNODE to data block + ULONG SizeDataBlock; // Size of data block for instance + + UCHAR VariableData[]; + // instance names and padding so data block begins on 8 byte boundry + + // data block +} WNODE_SINGLE_INSTANCE, *PWNODE_SINGLE_INSTANCE; + +/****************************************************************************** + * File: 1394.h (DDK?) + ******************************************************************************/ + +// common.h ??? +// Patch: GUIDs. +//#define LPGUID int* +// {C459DF55-DB08-11d1-B009-00A0C9081FF6} +LPGUID GUID_1394DIAG ; +// {737613E5-69EA-4b96-9C2A-EEBC220F4C39} +LPGUID GUID_1394VDEV ; + +// 1394.h, line 700. +#define REQUEST_ISOCH_FREE_RESOURCES 10 + +// 1394.h, line 721. +#define REQUEST_SET_LOCAL_HOST_PROPERTIES 31 + +// 1394.h, line 1060. +typedef struct _IRB_REQ_ISOCH_FREE_RESOURCES { + HANDLE hResource; // Resource handle +} IRB_REQ_ISOCH_FREE_RESOURCES; + +// 1394.h, line 1251. +typedef struct _IRB_REQ_SET_LOCAL_HOST_PROPERTIES { + ULONG nLevel; + PVOID Information; +} IRB_REQ_SET_LOCAL_HOST_PROPERTIES; + +// 1394.h, line 1409. +#define IRB_BUS_RESERVED_SZ 8 +#define IRB_PORT_RESERVED_SZ 8 + +typedef struct _IRB { + + // + // Holds the zero based Function number that corresponds to the request + // that device drivers are asking the 1394 Bus driver to carry out. + // + + ULONG FunctionNumber; + + // + // Holds Flags that may be unique to this particular operation. + // + + ULONG Flags; + + // + // Reserved for internal bus driver use and/or future expansion. + // + + ULONG_PTR BusReserved[IRB_BUS_RESERVED_SZ]; + + // + // Reserved for internal port driver usage. + // + + ULONG_PTR PortReserved[IRB_PORT_RESERVED_SZ]; + + // + // Holds the structures used in performing the various 1394 APIs. + // + + union { + +/* IRB_REQ_ASYNC_READ AsyncRead; */ +/* IRB_REQ_ASYNC_WRITE AsyncWrite; */ +/* IRB_REQ_ASYNC_LOCK AsyncLock; */ +/* IRB_REQ_ISOCH_ALLOCATE_BANDWIDTH IsochAllocateBandwidth; */ +/* IRB_REQ_ISOCH_ALLOCATE_CHANNEL IsochAllocateChannel; */ +/* IRB_REQ_ISOCH_ALLOCATE_RESOURCES IsochAllocateResources; */ +/* IRB_REQ_ISOCH_ATTACH_BUFFERS IsochAttachBuffers; */ +/* IRB_REQ_ISOCH_DETACH_BUFFERS IsochDetachBuffers; */ +/* IRB_REQ_ISOCH_FREE_BANDWIDTH IsochFreeBandwidth; */ +/* IRB_REQ_ISOCH_FREE_CHANNEL IsochFreeChannel; */ + IRB_REQ_ISOCH_FREE_RESOURCES IsochFreeResources; +/* IRB_REQ_ISOCH_LISTEN IsochListen; */ +/* IRB_REQ_ISOCH_QUERY_CURRENT_CYCLE_TIME IsochQueryCurrentCycleTime; */ +/* IRB_REQ_ISOCH_QUERY_RESOURCES IsochQueryResources; */ +/* IRB_REQ_ISOCH_SET_CHANNEL_BANDWIDTH IsochSetChannelBandwidth; */ +/* IRB_REQ_ISOCH_STOP IsochStop; */ +/* IRB_REQ_ISOCH_TALK IsochTalk; */ +/* #if(NTDDI_VERSION >= NTDDI_WINXP) */ +/* IRB_REQ_ISOCH_MODIFY_STREAM_PROPERTIES IsochModifyStreamProperties; */ +/* #endif */ +/* IRB_REQ_ALLOCATE_ADDRESS_RANGE AllocateAddressRange; */ +/* IRB_REQ_FREE_ADDRESS_RANGE FreeAddressRange; */ +/* IRB_REQ_GET_LOCAL_HOST_INFORMATION GetLocalHostInformation; */ +/* IRB_REQ_GET_1394_ADDRESS_FROM_DEVICE_OBJECT Get1394AddressFromDeviceObject; */ +/* IRB_REQ_CONTROL Control; */ +/* IRB_REQ_GET_MAX_SPEED_BETWEEN_DEVICES GetMaxSpeedBetweenDevices; */ +/* IRB_REQ_SET_DEVICE_XMIT_PROPERTIES SetDeviceXmitProperties; */ + IRB_REQ_SET_LOCAL_HOST_PROPERTIES SetLocalHostProperties; +/* IRB_REQ_GET_CONFIGURATION_INFORMATION GetConfigurationInformation; */ +/* #if(NTDDI_VERSION >= NTDDI_WIN7) */ +/* IRB_REQ_GET_CONFIG_ROM GetConfigRom; */ +/* #endif */ +/* IRB_REQ_BUS_RESET BusReset; */ +/* IRB_REQ_GET_GENERATION_COUNT GetGenerationCount; */ +/* IRB_REQ_SEND_PHY_CONFIGURATION_PACKET SendPhyConfigurationPacket; */ +/* #if(NTDDI_VERSION >= NTDDI_WIN7) */ +/* IRB_REQ_SEND_PHY_PACKET SendPhyPacket; */ +/* IRB_REQ_RECEIVE_PHY_PACKETS ReceivePhyPackets; */ +/* #endif */ +/* IRB_REQ_GET_SPEED_TOPOLOGY_MAPS GetSpeedTopologyMaps; */ +/* IRB_REQ_BUS_RESET_NOTIFICATION BusResetNotification; */ +/* IRB_REQ_ASYNC_STREAM AsyncStream; */ + + } u; + +} IRB, *PIRB; + +// 1394.h, line 1503 +#define SET_LOCAL_HOST_PROPERTIES_NO_CYCLE_STARTS 0x00000001 +#if(NTDDI_VERSION >= NTDDI_WINXP) +#define SET_LOCAL_HOST_PROPERTIES_CYCLE_START_CONTROL 0x00000001 +#endif +#define SET_LOCAL_HOST_PROPERTIES_GAP_COUNT 0x00000002 +#define SET_LOCAL_HOST_PROPERTIES_MODIFY_CROM 0x00000003 +#if(NTDDI_VERSION >= NTDDI_WINXP) +#define SET_LOCAL_HOST_PROPERTIES_MAX_PAYLOAD 0x00000004 +#endif +#if(NTDDI_VERSION >= NTDDI_VISTA) +#define SET_LOCAL_HOST_PROPERTIES_DEBUG_ENTRY 0x00000005 +#endif + +#if(NTDDI_VERSION >= NTDDI_WINXP) + typedef struct _SET_LOCAL_HOST_PROPS1 { + ULONG fulFlags; +} SET_LOCAL_HOST_PROPS1, *PSET_LOCAL_HOST_PROPS1; +#endif + +typedef struct _SET_LOCAL_HOST_PROPS2 { + ULONG GapCountLowerBound; +} SET_LOCAL_HOST_PROPS2, *PSET_LOCAL_HOST_PROPS2; + +// 1394.h, line 1542. +typedef struct _SET_LOCAL_HOST_PROPS3 { + + ULONG fulFlags; + HANDLE hCromData; + ULONG nLength; + PMDL Mdl; + +} SET_LOCAL_HOST_PROPS3, *PSET_LOCAL_HOST_PROPS3; + +// line 1590. +#define SLHP_FLAG_ADD_CROM_DATA 0x01 +#define SLHP_FLAG_REMOVE_CROM_DATA 0x02 + +typedef struct _ADDRESS_RANGE { + /* USHORT */ int AR_Off_High; + /* USHORT */ int AR_Length; + /* ULONG */ int AR_Off_Low; +} ADDRESS_RANGE, *PADDRESS_RANGE; + +// +// 1394 Cycle Time format. +// + +typedef struct _CYCLE_TIME { + ULONG CL_CycleOffset:12; // Bits 0-11 + ULONG CL_CycleCount:13; // Bits 12-24 + ULONG CL_SecondCount:7; // Bits 25-31 +} CYCLE_TIME, *PCYCLE_TIME; + +typedef +//__drv_requiresIRQL(DISPATCH_LEVEL) +void +(*PBUS_ISOCH_DESCRIPTOR_ROUTINE) ( + /*__in*/ PVOID Context1, + /*__in*/ PVOID Context2 + ); + +// +// Definition of Isoch Descriptor. +// + +typedef struct _ISOCH_DESCRIPTOR { + + // + // Flags (used in synchronization). + // + + ULONG fulFlags; + +/* // */ +/* // Mdl pointing to buffer. */ +/* // */ + +/* PMDL Mdl; */ + +/* // */ +/* // Length of combined buffer(s) as represented by the Mdl. */ +/* // */ + +/* ULONG ulLength; */ + +/* // */ +/* // Payload size of each Isoch packet to be used in this descriptor. */ +/* // */ + +/* ULONG nMaxBytesPerFrame; */ + +/* // */ +/* // Synchronization field; equivalent to Sy in the Isoch packet. */ +/* // */ + +/* ULONG ulSynch; */ + +/* // */ +/* // Synchronization field; equivalent to Tag in the Isoch packet. */ +/* // */ + +/* ULONG ulTag; */ + +/* // */ +/* // Cycle time field; returns time to be sent/received or when finished. */ +/* // */ + +/* CYCLE_TIME CycleTime; */ + +/* // */ +/* // Callback routine (if any) to be called when this descriptor completes. */ +/* // */ + +/* PBUS_ISOCH_DESCRIPTOR_ROUTINE Callback; */ + +/* // */ +/* // First context (if any) parameter to be passed when doing callbacks. */ +/* // */ + +/* PVOID Context1; */ + +/* // */ +/* // Second context (if any) parameter to be passed when doing callbacks. */ +/* // */ + +/* PVOID Context2; */ + +/* // */ +/* // Holds the final status of this descriptor. */ +/* // */ + +/* NTSTATUS status; */ + +/* // */ +/* // Reserved for the device driver who submitted this descriptor to */ +/* // stomp in. */ +/* // */ + +/* ULONG_PTR DeviceReserved[8]; */ + +/* // */ +/* // Reserved for the bus driver to stomp in. */ +/* // */ + +/* ULONG_PTR BusReserved[8]; */ + +/* // */ +/* // Reserved for the port driver to stomp in. */ +/* // */ + +/* ULONG_PTR PortReserved[16]; */ + +} ISOCH_DESCRIPTOR, *PISOCH_DESCRIPTOR; + +typedef struct _NODE_DEVICE_EXTENSION { + +/* // */ +/* // Holds Tag to determine if this is really a "Node" Device Extension. */ +/* // */ + +/* ULONG Tag; */ + +/* // */ +/* // Holds the flag as to whether or not we've read the configuration */ +/* // information out of this device. */ +/* // */ + +/* BOOLEAN bConfigurationInformationValid; */ + +/* // */ +/* // Holds the Configuration Rom for this device. Multi-functional */ +/* // devices (i.e. many units) will share this same Config Rom */ +/* // structure, but they are represented as a different Device Object. */ +/* // This is not the entire Config Rom, but does contain the root directory */ +/* // as well as everything in front of it. */ +/* // */ + +/* PCONFIG_ROM ConfigRom; */ + +/* // */ +/* // Holds the length of the UnitDirectory pointer. */ +/* // */ + +/* ULONG UnitDirectoryLength; */ + +/* // */ +/* // Holds the Unit Directory for this device. Even on multi-functional */ +/* // devices (i.e. many units) this should be unique to each Device Object. */ +/* // */ + +/* PVOID UnitDirectory; */ + +/* // */ +/* // Holds the Unit Directory location for this device. Only the lower 48 */ +/* // bits are valid in this IO_ADDRESS. Useful for computing offsets from */ +/* // within the UnitDirectory as all offsets are relative. */ +/* // */ + +/* IO_ADDRESS UnitDirectoryLocation; */ + +/* // */ +/* // Holds the length of the UnitDependentDirectory pointer. */ +/* // */ + +/* ULONG UnitDependentDirectoryLength; */ + +/* // */ +/* // Holds the Unit Dependent directory for this device. */ +/* // */ + +/* PVOID UnitDependentDirectory; */ + +/* // */ +/* // Holds the Unit Dependent Directory location for this device. Only the */ +/* // lower 48 bits are valid in this IO_ADDRESS. Useful for computing */ +/* // offsets from within the UnitDependentDirectory as offsets are relative. */ +/* // */ + +/* IO_ADDRESS UnitDependentDirectoryLocation; */ + +/* // */ +/* // Holds the length of the VendorLeaf pointer. */ +/* // */ + +/* ULONG VendorLeafLength; */ + +/* // */ +/* // Holds the pointer to the Vendor Leaf information */ +/* // */ + +/* PTEXTUAL_LEAF VendorLeaf; */ + +/* // */ +/* // Holds the length of the VendorLeaf pointer. */ +/* // */ + +/* ULONG ModelLeafLength; */ + +/* // */ +/* // Holds the pointer to the Model Leaf information. */ +/* // */ + +/* PTEXTUAL_LEAF ModelLeaf; */ + +/* // */ +/* // Holds the 1394 10 bit BusId / 6 bit NodeId structure. */ +/* // */ + +/* NODE_ADDRESS NodeAddress; */ + +/* // */ +/* // Holds the speed to be used in reaching this device. */ +/* // */ + +/* UCHAR Speed; */ + +/* // */ +/* // Holds the priority at which to send packets. */ +/* // */ + +/* UCHAR Priority; */ + +/* // */ +/* // Holds the Irp used to notify this device object about events. */ +/* // */ + +/* PIRP Irp; */ + +/* // */ +/* // Holds the Device Object that this Device Extension hangs off of. */ +/* // */ + +/* PDEVICE_OBJECT DeviceObject; */ + + // + // Holds the Port Device Object that this Device hangs off of. + // + + PDEVICE_OBJECT PortDeviceObject; + +/* // */ +/* // Holds the pointer to corresponding information about this deivce */ +/* // in the bus driver's head. */ +/* // */ + +/* PVOID DeviceInformation; */ + +/* // */ +/* // Holds the pointer to the bus reset notification routine (if any). */ +/* // */ + +/* PBUS_BUS_RESET_NOTIFICATION ResetRoutine; */ + +/* // */ +/* // Holds the pointer to the context the client wanted when bus reset occurs. */ +/* // */ + +/* PVOID ResetContext; */ + +} NODE_DEVICE_EXTENSION, *PNODE_DEVICE_EXTENSION; + +// inc/1393api.h +typedef struct _SET_LOCAL_HOST_INFORMATION { + ULONG nLevel; + ULONG ulBufferSize; + /* UCHAR */char Information[1]; +} SET_LOCAL_HOST_INFORMATION, *PSET_LOCAL_HOST_INFORMATION; + +NTSTATUS +WdfStringCreate(PCUNICODE_STRING original, + PWDF_OBJECT_ATTRIBUTES a, + WDFSTRING* out) { + int x; + WDFSTRING s; + + if (x) { + s = _SLAyer_malloc(sizeof(WDFSTRING)); + *out = s; + return STATUS_SUCCESS; + } else { + return STATUS_INSUFFICIENT_RESOURCES; + } +} + +DECLARE_HANDLE(WDFMEMORY); + +// For toasterMof.h +DECLARE_HANDLE(CHAR); + +/****************************************************************************** + * File: wdftimer.h + ******************************************************************************/ +typedef +//_Function_class_(EVT_WDF_TIMER) +//_IRQL_requires_same_ +//_IRQL_requires_max_(DISPATCH_LEVEL) +VOID +EVT_WDF_TIMER( + _In_ + WDFTIMER Timer + ); + +typedef EVT_WDF_TIMER *PFN_WDF_TIMER; + +// line 51 +typedef struct _WDF_TIMER_CONFIG { + ULONG Size; + PFN_WDF_TIMER EvtTimerFunc; + ULONG Period; + BOOLEAN AutomaticSerialization; + ULONG TolerableDelay; +} WDF_TIMER_CONFIG, *PWDF_TIMER_CONFIG; + +VOID +FORCEINLINE +WDF_TIMER_CONFIG_INIT( + /* _Out_*/ PWDF_TIMER_CONFIG Config, + /* _In_ */ PFN_WDF_TIMER EvtTimerFunc + ) +{ + RtlZeroMemory(Config, sizeof(WDF_TIMER_CONFIG)); + Config->Size = sizeof(WDF_TIMER_CONFIG); + Config->EvtTimerFunc = EvtTimerFunc; + Config->Period = 0; + Config->AutomaticSerialization = TRUE; + Config->TolerableDelay = 0; +} + +typedef +/*_Must_inspect_result_ */ +/*_IRQL_requires_max_(DISPATCH_LEVEL) */ +WDFAPI +NTSTATUS +(*PFN_WDFTIMERCREATE)( + /*_In_ */ + PWDF_DRIVER_GLOBALS DriverGlobals, + /*_In_ */ + PWDF_TIMER_CONFIG Config, + /*_In_ */ + PWDF_OBJECT_ATTRIBUTES Attributes, + /*_Out_ */ + WDFTIMER* Timer + ); + +/*_Must_inspect_result_*/ +/*_IRQL_requires_max_(DISPATCH_LEVEL)*/ +NTSTATUS +FORCEINLINE +WdfTimerCreate( + /*_In_*/ + PWDF_TIMER_CONFIG Config, + /*_In_*/ + PWDF_OBJECT_ATTRIBUTES Attributes, + /*_Out_*/ + WDFTIMER* Timer + ) +{ + WDFTIMER timer; + + timer = (WDFTIMER)_SLAyer_malloc(sizeof(SLAyer_WDFOBJECT)); + timer->typ = SLAyerWdfTimer; + timer->Context = + (Attributes == WDF_NO_OBJECT_ATTRIBUTES) ? NULL : + (*(Attributes->MkContext))() ; + SL_Timer = timer; + *Timer = SL_Timer; + + return STATUS_SUCCESS; +} + +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +BOOLEAN +(*PFN_WDFTIMERSTART)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFTIMER Timer, + // _In_ + LONGLONG DueTime + ); + +// _IRQL_requires_max_(DISPATCH_LEVEL) +BOOLEAN +FORCEINLINE +WdfTimerStart( + // _In_ + WDFTIMER Timer, + // _In_ + LONGLONG DueTime + ) +{ + // return ((PFN_WDFTIMERSTART) WdfFunctions[WdfTimerStartTableIndex])(WdfDriverGlobals, Timer, DueTime); + SLAyer_nondetT(BOOLEAN); +} + +typedef +// _When_(Wait == __true, _IRQL_requires_max_(PASSIVE_LEVEL)) +// _When_(Wait == __false, _IRQL_requires_max_(DISPATCH_LEVEL)) +WDFAPI +BOOLEAN +(*PFN_WDFTIMERSTOP)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFTIMER Timer, + // _In_ + BOOLEAN Wait + ); + +/* Reimplementing. THe function WdfTimerStop calls this function, but + * this function is implemented by the WDF using some unknown array. --KK + * #PS637 + */ +// _When_(Wait == __true, _IRQL_requires_max_(PASSIVE_LEVEL)) +// _When_(Wait == __false, _IRQL_requires_max_(DISPATCH_LEVEL)) +BOOLEAN +FORCEINLINE +WdfTimerStop( + // _In_ + WDFTIMER Timer, + // _In_ + BOOLEAN Wait + ) +{ + BOOLEAN b; + return b; + // return ((PFN_WDFTIMERSTOP) WdfFunctions[WdfTimerStopTableIndex])(WdfDriverGlobals, Timer, Wait); +} + +/****************************************************************************** + * File: wdmguid.h + ******************************************************************************/ +DEFINE_GUID( GUID_DEVICE_INTERFACE_ARRIVAL, 0xcb3a4004L, 0x46f0, 0x11d0, 0xb0, 0x8f, 0x00, 0x60, 0x97, 0x13, 0x05, 0x3f ); +DEFINE_GUID( GUID_BUS_INTERFACE_STANDARD, 0x496B8280L, 0x6F25, 0x11D0, 0xBE, 0xAF, 0x08, 0x00, 0x2B, 0xE2, 0x09, 0x2F ); + +/****************************************************************************** + * File: wdfmemory.h + ******************************************************************************/ +// Line 47 +/* I have placed the definition of _WDFMEMORY_OFFSET in File: wdfiotarget.h as + * it is needed before this point in the file (in the early 3000s of lines, at + * time of writing) -- KK + */ + +// Line 134 +typedef +//_Must_inspect_result_ +//_When_(PoolType == 1 || PoolType == 257, _IRQL_requires_max_(APC_LEVEL)) +//_When_(PoolType == 0 || PoolType == 256, _IRQL_requires_max_(DISPATCH_LEVEL)) +WDFAPI +NTSTATUS +(*PFN_WDFMEMORYCREATE)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_opt_ + PWDF_OBJECT_ATTRIBUTES Attributes, + //_In_ + //_Strict_type_match_ + POOL_TYPE PoolType, + //_In_opt_ + ULONG PoolTag, + //_In_ + //_When_(BufferSize == 0, __drv_reportError(BufferSize cannot be zero)) + size_t BufferSize, + //_Out_ + WDFMEMORY* Memory, + //_Outptr_opt_result_bytebuffer_(BufferSize) + PVOID* Buffer + ); + +/* Creating a stub for this. The function WdfMemoryCreate below calls + * this using some unknown array. --KK #PS637 + */ +PFN_WDFMEMORYCREATE +WdfMemoryCreateTableIndex( + PWDF_OBJECT_ATTRIBUTES Attributes, + POOL_TYPE PoolType, + ULONG PoolTag, + size_t BufferSize, + WDFMEMORY* Memory, + PVOID* Buffer + ) +{ + return NULL; +} + +// Line 228 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +PVOID +(*PFN_WDFMEMORYGETBUFFER)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFMEMORY Memory, + //_Out_opt_ + size_t* BufferSize + ); + +/* Reimplementing myself. This function is called from + * WdfMemoryGetBuffer, and the WDF implements this function using some + * unknown array. --KK #PS637 + */ +PFN_WDFMEMORYGETBUFFER +WdfMemoryGetBufferTableIndex( + WDFMEMORY Memory, + size_t* BufferSize + ) +{ + return NULL; +} + +//_IRQL_requires_max_(DISPATCH_LEVEL) +PVOID +FORCEINLINE +WdfMemoryGetBuffer( + //_In_ + WDFMEMORY Memory, + //_Out_opt_ + size_t* BufferSize + ) +{ + return WdfMemoryGetBufferTableIndex(Memory, BufferSize); + //return ((PFN_WDFMEMORYGETBUFFER) WdfFunctions[WdfMemoryGetBufferTableIndex])(WdfDriverGlobals, Memory, BufferSize); +} + +//_Must_inspect_result_ +//_When_(PoolType == 1 || PoolType == 257, _IRQL_requires_max_(APC_LEVEL)) +//_When_(PoolType == 0 || PoolType == 256, _IRQL_requires_max_(DISPATCH_LEVEL)) +NTSTATUS +FORCEINLINE +WdfMemoryCreate( + //_In_opt_ + PWDF_OBJECT_ATTRIBUTES Attributes, + //_In_ + //_Strict_type_match_ + POOL_TYPE PoolType, + //_In_opt_ + ULONG PoolTag, + //_In_ + //_When_(BufferSize == 0, __drv_reportError(BufferSize cannot be zero)) + size_t BufferSize, + //_Out_ + WDFMEMORY* Memory, + //_Outptr_opt_result_bytebuffer_(BufferSize) + PVOID* Buffer + ) +{ + return WdfMemoryCreateTableIndex(Attributes, PoolType, PoolTag, + BufferSize, Memory, Buffer); + // return ((PFN_WDFMEMORYCREATE) WdfFunctions[WdfMemoryCreateTableIndex])(WdfDriverGlobals, Attributes, PoolType, PoolTag, BufferSize, Memory, Buffer); +} + +// line 422 +// _Must_inspect_result_ +// _When_(PoolType == 1 || PoolType == 257, _IRQL_requires_max_(APC_LEVEL)) +// _When_(PoolType == 0 || PoolType == 256, _IRQL_requires_max_(DISPATCH_LEVEL)) +NTSTATUS +FORCEINLINE +WdfLookasideListCreate( + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES LookasideAttributes, + // _In_ + // _When_(BufferSize == 0, __drv_reportError(BufferSize cannot be zero)) + size_t BufferSize, + // _In_ + // _Strict_type_match_ + POOL_TYPE PoolType, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES MemoryAttributes, + // _In_opt_ + ULONG PoolTag, + // _Out_ + WDFLOOKASIDE* Lookaside + ) +{ + NTSTATUS status; + return status; + // return ((PFN_WDFLOOKASIDELISTCREATE) WdfFunctions[WdfLookasideListCreateTableIndex])(WdfDriverGlobals, LookasideAttributes, BufferSize, PoolType, MemoryAttributes, PoolTag, Lookaside); +} + +/****************************************************************************** + * File: wdfcollection.h + ******************************************************************************/ + +// line 41 +typedef +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +NTSTATUS +(*PFN_WDFCOLLECTIONCREATE)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES CollectionAttributes, + // _Out_ + WDFCOLLECTION* Collection + ); + +// line 72 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +//WDFAPI +ULONG +(*PFN_WDFCOLLECTIONGETCOUNT)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFCOLLECTION Collection + ); + +// line 128 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +VOID +(*PFN_WDFCOLLECTIONREMOVE)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFCOLLECTION Collection, + // _In_ + WDFOBJECT Item + ); + +/* Reimplementing myself. This function is called from + * WdfCollectionRemove, but the WDF implements this function using some + * unknown array. --KK #PS637 + */ +// _IRQL_requires_max_(DISPATCH_LEVEL) +VOID +FORCEINLINE +WdfCollectionRemove( + // _In_ + WDFCOLLECTION Collection, + // _In_ + WDFOBJECT Item + ) +{ + // ((PFN_WDFCOLLECTIONREMOVE) WdfFunctions[WdfCollectionRemoveTableIndex])(WdfDriverGlobals, Collection, Item); +} + +// _Must_inspect_result_ +// _IRQL_requires_max_(DISPATCH_LEVEL) +// PS #640 Consider generalizing return values +NTSTATUS +FORCEINLINE +WdfCollectionCreate( + // _In_opt_ + PWDF_OBJECT_ATTRIBUTES CollectionAttributes, + // _Out_ + WDFCOLLECTION* Collection + ) +{ + // return ((PFN_WDFCOLLECTIONCREATE) WdfFunctions[WdfCollectionCreateTableIndex])(WdfDriverGlobals, CollectionAttributes, Collection); + SLAyer_nondetT(NTSTATUS); +} + +typedef +/*_Must_inspect_result_*/ +/*_IRQL_requires_max_(DISPATCH_LEVEL)*/ +WDFAPI +NTSTATUS +(*PFN_WDFCOLLECTIONADD)( + /*_In_*/ + PWDF_DRIVER_GLOBALS DriverGlobals, + /*_In_*/ + WDFCOLLECTION Collection, + /*_In_*/ + WDFOBJECT Object + ); + +/* My own implementation of WdfFunctions[WdfCollectionAddTableIndex], + * since the WDF does not provide one. -- KK #PS637 + */ +NTSTATUS +WdfCollectionAddTableIndex( + WDFCOLLECTION Collection, + WDFOBJECT Object) +{ + int x; + if(x){ return STATUS_SUCCESS; } + else { return STATUS_UNSUCCESSFUL; } +} + +// Line 186 +typedef +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +WDFOBJECT +(*PFN_WDFCOLLECTIONGETITEM)( + //_In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + //_In_ + WDFCOLLECTION Collection, + //_In_ + ULONG Index + ); + +PFN_WDFCOLLECTIONGETITEM +WdfCollectionGetItemTableIndex( + WDFCOLLECTION Collection, + ULONG Index + ) +{ + return NULL; +} + +//_IRQL_requires_max_(DISPATCH_LEVEL) +WDFOBJECT +FORCEINLINE +WdfCollectionGetItem( + //_In_ + WDFCOLLECTION Collection, + //_In_ + ULONG Index + ) +{ + return WdfCollectionGetItemTableIndex(Collection, Index); + //return ((PFN_WDFCOLLECTIONGETITEM) WdfFunctions[WdfCollectionGetItemTableIndex])(WdfDriverGlobals, Collection, Index); +} + +/*_Must_inspect_result_*/ +/*_IRQL_requires_max_(DISPATCH_LEVEL)*/ +// PS #640 Consider generalizing return values +NTSTATUS +FORCEINLINE +WdfCollectionAdd( + /*_In_*/ + WDFCOLLECTION Collection, + /*_In_*/ + WDFOBJECT Object + ) +{ + // WDF doesn't provide a WdfFunctions array + // return ((PFN_WDFCOLLECTIONADD) WdfFunctions[WdfCollectionAddTableIndex])(WdfDriverGlobals, Collection, Object); + return WdfCollectionAddTableIndex(Collection, Object); +} + + +ULONG +WdfCollectionGetCount( + WDFCOLLECTION Collection + ) +{ + return 1; +} + + +/****************************************************************************** + * File: wdfcore.h + ******************************************************************************/ +#define WDF_TIMEOUT_TO_MS ((LONGLONG) 1 * 10 * 1000) +#define WDF_TIMEOUT_TO_SEC ((LONGLONG) 1 * 10 * 1000 * 1000) + +WDF_REL_TIMEOUT_IN_SEC( + /*_In_*/ ULONGLONG Time + ) +{ + return Time * -1 * WDF_TIMEOUT_TO_SEC; +} + +LONGLONG +//FORCEINLINE +WDF_REL_TIMEOUT_IN_MS( + /*_In_*/ ULONGLONG Time + ) +{ + return Time * -1 * WDF_TIMEOUT_TO_MS; +} + +/* Moved these up, as they are needed earlier in the file. --KK + #define WDF_PTR_ADD_OFFSET_TYPE(_ptr, _offset, _type) \ + ((_type) (((PUCHAR) (_ptr)) + (_offset))) + + #define WDF_PTR_ADD_OFFSET(_ptr, _offset) \ + WDF_PTR_ADD_OFFSET_TYPE(_ptr, _offset, PVOID) +*/ + +/****************************************************************************** + * File: wdfresource.h + ******************************************************************************/ +// line 593 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +ULONG +(*PFN_WDFCMRESOURCELISTGETCOUNT)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFCMRESLIST List + ); + +/* PS#637 --KK */ +// _IRQL_requires_max_(DISPATCH_LEVEL) +ULONG +FORCEINLINE +WdfCmResourceListGetCount( + // _In_ + WDFCMRESLIST List + ) +{ + ULONG ulong; + return ulong; + // return ((PFN_WDFCMRESOURCELISTGETCOUNT) WdfFunctions[WdfCmResourceListGetCountTableIndex])(WdfDriverGlobals, List); +} + +// line 618 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +PCM_PARTIAL_RESOURCE_DESCRIPTOR +(*PFN_WDFCMRESOURCELISTGETDESCRIPTOR)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFCMRESLIST List, + // _In_ + ULONG Index + ); + +// _IRQL_requires_max_(DISPATCH_LEVEL) +PCM_PARTIAL_RESOURCE_DESCRIPTOR +FORCEINLINE +WdfCmResourceListGetDescriptor( + // _In_ + WDFCMRESLIST List, + // _In_ + ULONG Index + ) +{ + return NULL; + // return ((PFN_WDFCMRESOURCELISTGETDESCRIPTOR) WdfFunctions[WdfCmResourceListGetDescriptorTableIndex])(WdfDriverGlobals, List, Index); +} + +/****************************************************************************** + * File: string.h + ******************************************************************************/ + +/* My implementation. I can't find an implementation for this, but I got + * the header from km/crt/string.h. --KK + */ +size_t +wcslen( + const wchar_t * _Str + ) +{ + size_t size = 0; + while(*_Str){ + size++; + _Str++; + } + return size; +} + +/****************************************************************************** + * File: string.h + ******************************************************************************/ +// line 189 +extern const UNICODE_STRING SDDL_DEVOBJ_SYS_ALL_ADM_RWX_WORLD_RW_RES_R; + +/****************************************************************************** + * File: wdfcontrol.h + ******************************************************************************/ +// PS #644 DeviceInit lifetime +// _Must_inspect_result_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +PWDFDEVICE_INIT +FORCEINLINE +WdfControlDeviceInitAllocate( + // _In_ + WDFDRIVER Driver, + // _In_ + /*CONST*/ UNICODE_STRING* SDDLString + ) +{ + // return ((PFN_WDFCONTROLDEVICEINITALLOCATE) WdfFunctions[WdfControlDeviceInitAllocateTableIndex])(WdfDriverGlobals, Driver, SDDLString); + return &SL_WdfDeviceInit; +} + +// line 138 +// _IRQL_requires_max_(DISPATCH_LEVEL) +VOID +FORCEINLINE +WdfControlFinishInitializing( + // _In_ + WDFDEVICE Device + ) +{ + return; + // ((PFN_WDFCONTROLFINISHINITIALIZING) WdfFunctions[WdfControlFinishInitializingTableIndex])(WdfDriverGlobals, Device); +} + + +/***************************************************************************** + * File: km/mslldp.h + ****************************************************************************/ + +#define ETH_LENGTH_OF_ADDRESS 6 + +/***************************************************************************** + * File: xfilter.h + ****************************************************************************/ +#define ETH_IS_MULTICAST(Address) \ + (BOOLEAN)(((PUCHAR)(Address))[0] & ((UCHAR)0x01)) + +#define ETH_LENGTH_OF_ADDRESS 6 + +#define ETH_IS_BROADCAST(Address) \ + ((((PUCHAR)(Address))[0] == ((UCHAR)0xff)) && (((PUCHAR)(Address))[1] == ((UCHAR)0xff)) && (((PUCHAR)(Address))[2] == ((UCHAR)0xff)) && (((PUCHAR)(Address))[3] == ((UCHAR)0xff)) && (((PUCHAR)(Address))[4] == ((UCHAR)0xff)) && (((PUCHAR)(Address))[5] == ((UCHAR)0xff))) + +#define ETH_COMPARE_NETWORK_ADDRESSES(_A, _B, _Result) \ +{ \ + if (*(ULONG UNALIGNED *)&(_A)[2] > \ + *(ULONG UNALIGNED *)&(_B)[2]) \ + { \ + *(_Result) = 1; \ + } \ + else if (*(ULONG UNALIGNED *)&(_A)[2] < \ + *(ULONG UNALIGNED *)&(_B)[2]) \ + { \ + *(_Result) = (UINT)-1; \ + } \ + else if (*(USHORT UNALIGNED *)(_A) > \ + *(USHORT UNALIGNED *)(_B)) \ + { \ + *(_Result) = 1; \ + } \ + else if (*(USHORT UNALIGNED *)(_A) < \ + *(USHORT UNALIGNED *)(_B)) \ + { \ + *(_Result) = (UINT)-1; \ + } \ + else \ + { \ + *(_Result) = 0; \ + } \ +} + +/***************************************************************************** + * File: wdfinterrupt.h + ****************************************************************************/ +// line 66 +// This is the function that gets invoked when the hardware ISR occurs. +// This function is called at the IRQL at which the interrupt is serviced: +// - DIRQL for DIRQL interrupt handling. +// - PASSIVE_LEVEL for passive-level interrupt handling. +typedef +//_Function_class_(EVT_WDF_INTERRUPT_ISR) +// _IRQL_requires_same_ +// _IRQL_requires_min_(PASSIVE_LEVEL) +BOOLEAN +EVT_WDF_INTERRUPT_ISR( + // _In_ + WDFINTERRUPT Interrupt, + // _In_ + ULONG MessageID + ); + +typedef EVT_WDF_INTERRUPT_ISR *PFN_WDF_INTERRUPT_ISR; + +// This is the function that gets called back into the driver +// when the DpcForIsr fires. It will be called at DISPATCH_LEVEL. +typedef +// _Function_class_(EVT_WDF_INTERRUPT_DPC) +// _IRQL_requires_same_ +// _IRQL_requires_(DISPATCH_LEVEL) +VOID +EVT_WDF_INTERRUPT_DPC( + // _In_ + WDFINTERRUPT Interrupt, + // _In_ + WDFOBJECT AssociatedObject + ); + +typedef EVT_WDF_INTERRUPT_DPC *PFN_WDF_INTERRUPT_DPC; + +// This is the function that gets called back into the driver +// to enable the interrupt in the hardware. It will be called +// at the same IRQL at which the interrupt will be serviced: +// - DIRQL for DIRQL interrupt handling. +// - PASSIVE_LEVEL for passive-level interrupt handling. +typedef +// _Function_class_(EVT_WDF_INTERRUPT_ENABLE) +// _IRQL_requires_same_ +// _IRQL_requires_min_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_INTERRUPT_ENABLE( + // _In_ + WDFINTERRUPT Interrupt, + // _In_ + WDFDEVICE AssociatedDevice + ); + +typedef EVT_WDF_INTERRUPT_ENABLE *PFN_WDF_INTERRUPT_ENABLE; + +// This is the function that gets called back into the driver +// to disable the interrupt in the hardware. It will be called +// at the same IRQL at which the interrupt is serviced: +// - DIRQL for DIRQL interrupt handling. +// - PASSIVE_LEVEL for passive-level interrupt handling. +typedef +// _Function_class_(EVT_WDF_INTERRUPT_DISABLE) +// _IRQL_requires_same_ +// _IRQL_requires_min_(PASSIVE_LEVEL) +NTSTATUS +EVT_WDF_INTERRUPT_DISABLE( + // _In_ + WDFINTERRUPT Interrupt, + // _In_ + WDFDEVICE AssociatedDevice + ); + +typedef EVT_WDF_INTERRUPT_DISABLE *PFN_WDF_INTERRUPT_DISABLE; + +// line 87 +typedef +// _Function_class_(EVT_WDF_INTERRUPT_SYNCHRONIZE) +// _IRQL_requires_same_ +// _IRQL_requires_min_(PASSIVE_LEVEL) +BOOLEAN +EVT_WDF_INTERRUPT_SYNCHRONIZE( + // _In_ + WDFINTERRUPT Interrupt, + // _In_ + WDFCONTEXT Context + ); + +typedef EVT_WDF_INTERRUPT_SYNCHRONIZE *PFN_WDF_INTERRUPT_SYNCHRONIZE; + +// line 176 +typedef EVT_WDF_INTERRUPT_DISABLE *PFN_WDF_INTERRUPT_DISABLE; + +// +// Interrupt Configuration Structure +// +typedef struct _WDF_INTERRUPT_CONFIG { + ULONG Size; + // If this interrupt is to be synchronized with other interrupt(s) assigned + // to the same WDFDEVICE, create a WDFSPINLOCK and assign it to each of the + // WDFINTERRUPTs config. + WDFSPINLOCK SpinLock; +/* + WDF_TRI_STATE ShareVector; + BOOLEAN FloatingSave; + // DIRQL handling: automatic serialization of the DpcForIsr/WaitItemForIsr. + // Passive-level handling: automatic serialization of all callbacks. + BOOLEAN AutomaticSerialization; + // Event Callbacks + PFN_WDF_INTERRUPT_ISR EvtInterruptIsr; + PFN_WDF_INTERRUPT_DPC EvtInterruptDpc; +*/ + PFN_WDF_INTERRUPT_ENABLE EvtInterruptEnable; + PFN_WDF_INTERRUPT_DISABLE EvtInterruptDisable; +/* + PFN_WDF_INTERRUPT_WORKITEM EvtInterruptWorkItem; + // These fields are only used when interrupt is created in + // EvtDevicePrepareHardware callback. + PCM_PARTIAL_RESOURCE_DESCRIPTOR InterruptRaw; + PCM_PARTIAL_RESOURCE_DESCRIPTOR InterruptTranslated; + // Optional passive lock for handling interrupts at passive-level. + WDFWAITLOCK WaitLock; + // TRUE: handle interrupt at passive-level. + // FALSE: handle interrupt at DIRQL level. This is the default. + BOOLEAN PassiveHandling; + // TRUE: Interrupt is reported inactive on explicit power down + // instead of disconnecting it. + // FALSE: Interrupt is disconnected instead of reporting inactive + // on explicit power down. + // DEFAULT: Framework decides the right value. + WDF_TRI_STATE ReportInactiveOnPowerDown; +*/ +} WDF_INTERRUPT_CONFIG, *PWDF_INTERRUPT_CONFIG; + +/***************************************************************************** + * File: wdfdmaenabler.h + ****************************************************************************/ +// line 38 +typedef enum _WDF_DMA_PROFILE { + WdfDmaProfileInvalid = 0, + WdfDmaProfilePacket, + WdfDmaProfileScatterGather, + WdfDmaProfilePacket64, + WdfDmaProfileScatterGather64, + WdfDmaProfileScatterGatherDuplex, + WdfDmaProfileScatterGather64Duplex, + WdfDmaProfileSystem, + WdfDmaProfileSystemDuplex, +} WDF_DMA_PROFILE; + +typedef enum _WDF_DMA_DIRECTION { + WdfDmaDirectionReadFromDevice = FALSE, + WdfDmaDirectionWriteToDevice = TRUE, +} WDF_DMA_DIRECTION; + +// line 158 +typedef struct _WDF_DMA_ENABLER_CONFIG { + // Size of this structure in bytes + ULONG Size; +/* + // One of the above WDF_DMA_PROFILES + WDF_DMA_PROFILE Profile; + // Maximum DMA Transfer handled in bytes. + size_t MaximumLength; + // The various DMA PnP/Power event callbacks + PFN_WDF_DMA_ENABLER_FILL EvtDmaEnablerFill; + PFN_WDF_DMA_ENABLER_FLUSH EvtDmaEnablerFlush; + PFN_WDF_DMA_ENABLER_DISABLE EvtDmaEnablerDisable; + PFN_WDF_DMA_ENABLER_ENABLE EvtDmaEnablerEnable; + PFN_WDF_DMA_ENABLER_SELFMANAGED_IO_START EvtDmaEnablerSelfManagedIoStart; + PFN_WDF_DMA_ENABLER_SELFMANAGED_IO_STOP EvtDmaEnablerSelfManagedIoStop; + // Overrides the address width specified by the DMA profile. + ULONG AddressWidthOverride; + // Overrides the version of the WDM DMA interfaces that WDF uses + // (0 for default). + ULONG WdmDmaVersionOverride; + // Bit field combination of values from the WDF_DMA_ENABLER_CONFIG_FLAGS + // enumeration + ULONG Flags; +*/ +} WDF_DMA_ENABLER_CONFIG, *PWDF_DMA_ENABLER_CONFIG; + +/***************************************************************************** + * File: wdfdmatransaction.h + ****************************************************************************/ +typedef +// _Function_class_(EVT_WDF_PROGRAM_DMA) +// _IRQL_requires_same_ +// _IRQL_requires_(DISPATCH_LEVEL) +BOOLEAN +EVT_WDF_PROGRAM_DMA( + // _In_ + WDFDMATRANSACTION Transaction, + // _In_ + WDFDEVICE Device, + // _In_ + WDFCONTEXT Context, + // _In_ + WDF_DMA_DIRECTION Direction, + // _In_ + PSCATTER_GATHER_LIST SgList + ); + +/***************************************************************************** + * File: wdfworkitem.h + ****************************************************************************/ +// line 39 +// This is the function that gets called back into the driver +// when the WorkItem fires. +// +typedef +// _Function_class_(EVT_WDF_WORKITEM) +// _IRQL_requires_same_ +// _IRQL_requires_max_(PASSIVE_LEVEL) +VOID +EVT_WDF_WORKITEM( + // _In_ + WDFWORKITEM WorkItem + ); + +typedef EVT_WDF_WORKITEM *PFN_WDF_WORKITEM; + +// line 66 +typedef struct _WDF_WORKITEM_CONFIG { + ULONG Size; + PFN_WDF_WORKITEM EvtWorkItemFunc; + // If this is TRUE, the workitem will automatically serialize + // with the event callback handlers of its Parent Object. + // + // Parent Object's callback constraints should be compatible + // with the work item (PASSIVE_LEVEL), or the request will fail. + BOOLEAN AutomaticSerialization; +} WDF_WORKITEM_CONFIG, *PWDF_WORKITEM_CONFIG; + +/***************************************************************************** + * File: ntddndis.h + ****************************************************************************/ +// line 199 +typedef ULONG NDIS_OID, *PNDIS_OID; + +// line 541 +#define OID_GEN_LINK_SPEED 0x00010107 +#define OID_GEN_MEDIA_CONNECT_STATUS 0x00010114 +#define OID_GEN_CURRENT_PACKET_FILTER 0x0001010E + +//line 2308 +typedef struct _NDIS_PM_PACKET_PATTERN +{ + ULONG Priority; // Importance of the given pattern. + ULONG Reserved; // Context information for transports. + ULONG MaskSize; // Size in bytes of the pattern mask. + ULONG PatternOffset; // Offset from beginning of this + // structure to the pattern bytes. + ULONG PatternSize; // Size in bytes of the pattern. + ULONG PatternFlags; // Flags (TBD). +} NDIS_PM_PACKET_PATTERN, *PNDIS_PM_PACKET_PATTERN; + +//line 2314 +typedef enum _NDIS_DEVICE_POWER_STATE +{ + NdisDeviceStateUnspecified = 0, +/* + NdisDeviceStateD0, + NdisDeviceStateD1, + NdisDeviceStateD2, + NdisDeviceStateD3, + NdisDeviceStateMaximum +*/ +} NDIS_DEVICE_POWER_STATE, *PNDIS_DEVICE_POWER_STATE; + +typedef struct _NDIS_PM_WAKE_UP_CAPABILITIES +{ + NDIS_DEVICE_POWER_STATE MinMagicPacketWakeUp; +/* + NDIS_DEVICE_POWER_STATE MinPatternWakeUp; + NDIS_DEVICE_POWER_STATE MinLinkChangeWakeUp; +*/ +} NDIS_PM_WAKE_UP_CAPABILITIES, *PNDIS_PM_WAKE_UP_CAPABILITIES; + +typedef struct _NDIS_PNP_CAPABILITIES +{ + ULONG Flags; + NDIS_PM_WAKE_UP_CAPABILITIES WakeUpCapabilities; +} NDIS_PNP_CAPABILITIES, *PNDIS_PNP_CAPABILITIES; + +// line 2487 + typedef enum _NDIS_MEDIA_STATE +{ + NdisMediaStateConnected, + NdisMediaStateDisconnected +} NDIS_MEDIA_STATE, *PNDIS_MEDIA_STATE; + +// line 2530 +typedef int NDIS_STATUS, *PNDIS_STATUS; + +/***************************************************************************** + * File: shared/devioctl.h + ****************************************************************************/ +// line 162 +#define FILE_READ_ACCESS ( 0x0001 ) // file & pipe +#define FILE_WRITE_ACCESS ( 0x0002 ) // file & pipe + +/***************************************************************************** + * File: km/miniport.h + ****************************************************************************/ +// line 143 +#define MEMORY_ALLOCATION_ALIGNMENT 16 + +// line 232 +// There +#define DECLSPEC_ALIGN(x) + +//line 6429 +#define PCI_WHICHSPACE_CONFIG 0x0 + +/***************************************************************************** + * File: sal.h + * Note that this is SAL 1.x that is required for PCI + ****************************************************************************/ +#define __field_ecount(fe) + +/***************************************************************************** + * File: wdfcommonbuffer.h + ****************************************************************************/ +// line 155 +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +PVOID +(*PFN_WDFCOMMONBUFFERGETALIGNEDVIRTUALADDRESS)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFCOMMONBUFFER CommonBuffer + ); + +// _IRQL_requires_max_(DISPATCH_LEVEL) +PVOID +FORCEINLINE +WdfCommonBufferGetAlignedVirtualAddress( + // _In_ + WDFCOMMONBUFFER CommonBuffer + ) +{ + return NULL; + //return ((PFN_WDFCOMMONBUFFERGETALIGNEDVIRTUALADDRESS) WdfFunctions[WdfCommonBufferGetAlignedVirtualAddressTableIndex])(WdfDriverGlobals, CommonBuffer); +} + +typedef +// _IRQL_requires_max_(DISPATCH_LEVEL) +WDFAPI +PHYSICAL_ADDRESS +(*PFN_WDFCOMMONBUFFERGETALIGNEDLOGICALADDRESS)( + // _In_ + PWDF_DRIVER_GLOBALS DriverGlobals, + // _In_ + WDFCOMMONBUFFER CommonBuffer + ); + +// _IRQL_requires_max_(DISPATCH_LEVEL) +PHYSICAL_ADDRESS +FORCEINLINE +WdfCommonBufferGetAlignedLogicalAddress( + // _In_ + WDFCOMMONBUFFER CommonBuffer + ) +{ + PHYSICAL_ADDRESS p; + return p; + // return ((PFN_WDFCOMMONBUFFERGETALIGNEDLOGICALADDRESS) WdfFunctions[WdfCommonBufferGetAlignedLogicalAddressTableIndex])(WdfDriverGlobals, CommonBuffer); +} + +#endif // #ifndef _HARNESS_H_ diff --git a/test/kmdf/microtests/WdfStringCreate_ObjectDelete.c b/test/kmdf/microtests/WdfStringCreate_ObjectDelete.c new file mode 100644 index 0000000..40ac647 --- /dev/null +++ b/test/kmdf/microtests/WdfStringCreate_ObjectDelete.c @@ -0,0 +1,14 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "harness.h" + +void +main () { + WDFSTRING s; + NTSTATUS status; + + status = WdfStringCreate(NULL,WDF_NO_OBJECT_ATTRIBUTES,&s); + if (NT_SUCCESS(status)) { + WdfObjectDelete(s); + } +} diff --git a/test/multi/link/extern.c b/test/multi/link/extern.c new file mode 100644 index 0000000..5e83780 --- /dev/null +++ b/test/multi/link/extern.c @@ -0,0 +1,5 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +int f() { return 0; } + +int g() { return 1; } diff --git a/test/multi/link/main.c b/test/multi/link/main.c new file mode 100644 index 0000000..5374db9 --- /dev/null +++ b/test/multi/link/main.c @@ -0,0 +1,18 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +int f(); + +static int g() { return 2; } + +void main() { + int x; + int y; + + x = f(); + y = g(); + + assert(x == 0); /* succeeds if f from extern.c called */ + assert(y == 2); /* succeeds if g from main.c called */ +} diff --git a/test/other/ExAllocatePoolWithTag.c b/test/other/ExAllocatePoolWithTag.c new file mode 100644 index 0000000..078f0ae --- /dev/null +++ b/test/other/ExAllocatePoolWithTag.c @@ -0,0 +1,48 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + OS Model's definition of ExAllocatePoolWithTag so as to + Alloc in terms of type rather than size. + + This deals with code in the form of + ExAllocatePoolWithTag(PoolType,sizeof(Type),Tag). But not when no sizeof, + or sizeof plus additional operators are used, like + ExAllocatePoolWithTag(NonPagedPool, Ro_SetLocalHostProps3->nLength, + POOLTAG_KMDF_VDEV) in kmdf_vdev_api.c. Actually, cl wraps the right cast + around a call to ExAllocatePoolWithTag to not require a macro to do this. +*/ + + +typedef enum _POOL_TYPE { + NonPagedPool, +/* PagedPool, */ +/* NonPagedPoolMustSucceed, */ +/* DontUseThisType, */ +/* NonPagedPoolCacheAligned, */ +/* PagedPoolCacheAligned, */ +/* NonPagedPoolCacheAlignedMustS, */ +/* MaxPoolType, */ +/* NonPagedPoolSession = 32, */ +/* PagedPoolSession = NonPagedPoolSession + 1, */ +/* NonPagedPoolMustSucceedSession = PagedPoolSession + 1, */ +/* DontUseThisTypeSession = NonPagedPoolMustSucceedSession + 1, */ +/* NonPagedPoolCacheAlignedSession = DontUseThisTypeSession + 1, */ +/* PagedPoolCacheAlignedSession = NonPagedPoolCacheAlignedSession + 1, */ +/* NonPagedPoolCacheAlignedMustSSession = PagedPoolCacheAlignedSession + 1, */ +} POOL_TYPE; + +/* Redef to get the type rather than size. */ +#define sizeof(T) T + +#define sdv_ExAllocatePoolWithTag(PoolType,TypeName,Tag) \ + (TypeName*)malloc(32) + + + +void main() +{ + int* p; + p = sdv_ExAllocatePoolWithTag(NonPagedPool, sizeof(int), 4); + + // assert that p->(int)r. +} diff --git a/test/other/addr_of_global_struct.c b/test/other/addr_of_global_struct.c new file mode 100644 index 0000000..5368fe6 --- /dev/null +++ b/test/other/addr_of_global_struct.c @@ -0,0 +1,36 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Test case for PS #603. The load to x below is like + (&fdoAttributes)->ContextTypeInfo = (&_WDF_DEVICE_EXTENSION_TYPE_INFO)->UniqueType; + from wdf_device_create.c + The other loads are variations of the x one. +**/ + + +struct _RECT { + int Length; + int Width; +}; + +typedef struct _RECT RECT; + +RECT r; + +void main () +{ + int x,y,z ; + RECT *pr; + + // #1 addr of r directly + x = (&r)->Length ; + + // #2 addr or r via an intermediate + pr = &r; + y = pr->Length; + + // #3 access r.Length + z = r.Length ; + + End: return; +} diff --git a/test/other/address_arith.c b/test/other/address_arith.c new file mode 100644 index 0000000..64d2711 --- /dev/null +++ b/test/other/address_arith.c @@ -0,0 +1,18 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +struct s { + int *a; + int *b; +}; + +void main() { + struct s x; + int **ptr; + int y; + + x.b = &y; + ptr = &x.a; + ptr++; + *ptr = 0; // UNSAFE unless we know there is no padding between a and b members of s + *x.b = 0; // UNSAFE if we do know there is no padding between a and b members of s +} diff --git a/test/other/address_of.c b/test/other/address_of.c new file mode 100644 index 0000000..fd292b4 --- /dev/null +++ b/test/other/address_of.c @@ -0,0 +1,15 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + y is an alias of &x. + **/ + +#include "slayer.h" + +void main() { + int x; + int *y = &x; + *y = 0; + FAIL_IF(x != 0) ; + return; +} diff --git a/test/other/address_of2.c b/test/other/address_of2.c new file mode 100644 index 0000000..6adc42d --- /dev/null +++ b/test/other/address_of2.c @@ -0,0 +1,33 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + p is an alias of x. + **/ + +#include "slayer.h" + +/* + f's x should be heapified (it has it's address taken). It needs to be + alloc/free-ed at the start/end of f. + + This program is a test-case for a bug # in SlamTranslator in which the + to-be-heapified set wasn't implemented as a set. x was being malloc/free-ed + as many times as it occured in the body of f. + +*/ +void f() { + int x; + int *p; + + p = &x; + p = &x; // Just another mention of &x. + *p = 0; + FAIL_IF(x!=0); + + return; +} + +void main() +{ + f(); +} diff --git a/test/other/address_of_global.c b/test/other/address_of_global.c new file mode 100644 index 0000000..54dfcf8 --- /dev/null +++ b/test/other/address_of_global.c @@ -0,0 +1,14 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + y is an alias of the global x. + **/ + +int x; + +void main() { + int *y = &x; + *y = 0; + assert(x==0); + return; +} diff --git a/test/other/address_of_malloced_struct.c b/test/other/address_of_malloced_struct.c new file mode 100644 index 0000000..02f2f9a --- /dev/null +++ b/test/other/address_of_malloced_struct.c @@ -0,0 +1,21 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + y is an alias of an s->a. + **/ + +#include "slayer.h" + +typedef struct _ls {int car; struct ls* cdr;} ls; + +void main() { + ls* x; + int* y; + x = (ls*)malloc(sizeof(ls)); + x->car = 42; + y = 0; + y = &(x->car); + FAIL_IF( *y != 42 ) ; + free(x); + return; +} diff --git a/test/other/address_of_struct.c b/test/other/address_of_struct.c new file mode 100644 index 0000000..a80e173 --- /dev/null +++ b/test/other/address_of_struct.c @@ -0,0 +1,23 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + pa is an alias of an s.a. + **/ + +#include "slayer.h" + +struct s { + int a; +}; + +void main() { + int *pa; + struct s x; + + pa = &(x.a); + *pa = 0; + + FAIL_IF(x.a != 0); + return; + +} diff --git a/test/other/address_taken_assigned_by_return.c b/test/other/address_taken_assigned_by_return.c new file mode 100644 index 0000000..b168aed --- /dev/null +++ b/test/other/address_taken_assigned_by_return.c @@ -0,0 +1,13 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +int f() { + return 1; +} + +main() { + int s; + int * ps; + ps = & s; + s = f(); + assert(*ps == 1); +} diff --git a/test/other/alloc_object_into_array.c b/test/other/alloc_object_into_array.c new file mode 100644 index 0000000..80bd90d --- /dev/null +++ b/test/other/alloc_object_into_array.c @@ -0,0 +1,186 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Store a new object into array[0], array[1], etc. Because of how + SLAyer treats arrays (compacts into one-elt), we see a LEAK of the + elt stored in array[0]. + + Code excerpted from src7600/wmi/wmisamp/wmisamp.c +*/ +#include "slayer.h" + +#define FIELD_OFFSET _SLAyer_offsetof +#define ALIGN_UP(len,ty) len + +#define __in +#define PVOID void* +#define BOOLEAN int +#define UCHAR int +#define USHORT int +#define ULONG int +#define ULONGLONG int +#define CHAR int +#define SHORT int +#define LONG int +#define LONGLONG int +#define VOID void + +#define NonPagedPool 0 + +void RtlCopyMemory(void* Dest, void* Src, int Len) +{ + // *Dest = *Src; +} + +void* ExAllocatePoolWithTag(unsigned int Pool, unsigned int Size, int Tag) +{ + return malloc(Size); +} + + +#define EC1_COUNT 4 + +typedef struct _EC1 +{ + // boolean data + BOOLEAN Xboolean; + #define EC1_Xboolean_SIZE sizeof(BOOLEAN) + #define EC1_Xboolean_ID 1 + + // unsigned character data + UCHAR Xuint8; + #define EC1_Xuint8_SIZE sizeof(UCHAR) + #define EC1_Xuint8_ID 2 + + // unsigned short data + USHORT Xuint16; + #define EC1_Xuint16_SIZE sizeof(USHORT) + #define EC1_Xuint16_ID 3 + + // unsigned long data + ULONG Xuint32; + #define EC1_Xuint32_SIZE sizeof(ULONG) + #define EC1_Xuint32_ID 4 + + // unsigned long long data + ULONGLONG Xuint64; + #define EC1_Xuint64_SIZE sizeof(ULONGLONG) + #define EC1_Xuint64_ID 5 + + // signed byte data + CHAR Xint8; + #define EC1_Xint8_SIZE sizeof(CHAR) + #define EC1_Xint8_ID 6 + + // singed short data + SHORT Xint16; + #define EC1_Xint16_SIZE sizeof(SHORT) + #define EC1_Xint16_ID 7 + + // singed long data + LONG Xint32; + #define EC1_Xint32_SIZE sizeof(LONG) + #define EC1_Xint32_ID 8 + + // signed long long data + LONGLONG Xint64; + #define EC1_Xint64_SIZE sizeof(LONGLONG) + #define EC1_Xint64_ID 9 + +} EC1, *PEC1; + +#define EC1_SIZE (FIELD_OFFSET(EC1, Xint64) + EC1_Xint64_SIZE) + +// +// Data storage for WMI data blocks. +// +typedef struct _WMI_SAMPLE_DEVICE_DATA { + + ULONG Ec1Count; + ULONG Ec1Length[EC1_COUNT]; + ULONG Ec1ActualLength[EC1_COUNT]; + PEC1 Ec1[EC1_COUNT]; +/* WDFSPINLOCK Ec1Lock; */ + +} WMI_SAMPLE_DEVICE_DATA, *PWMI_SAMPLE_DEVICE_DATA; + + +#define WMI_SAMPLE_TAG (LONG)'SimW' + +VOID +WmiSampSetEc1( + __in PWMI_SAMPLE_DEVICE_DATA WmiDeviceData, + __in PVOID Buffer, + __in ULONG Length, + __in ULONG Index + ) +{ + PEC1 ec1; + ULONG ec1Length = ALIGN_UP(Length, PVOID); + PVOID oldBuffer = NULL; + + if (Index >= EC1_COUNT) { + return; + } + + ec1 = ExAllocatePoolWithTag(NonPagedPool, ec1Length, WMI_SAMPLE_TAG); + if (ec1 != NULL) { + + RtlCopyMemory(ec1, Buffer, Length); + + // + // Acquire the lock to protect access to the EC1 data since multiple + // threads could be trying to access the common data concurrently. + // +/* WdfSpinLockAcquire(WmiDeviceData->Ec1Lock); */ + + oldBuffer = WmiDeviceData->Ec1[Index]; + WmiDeviceData->Ec1[Index] = ec1; // SLAyer: doesn't get stored into. + WmiDeviceData->Ec1Length[Index] = ec1Length; + WmiDeviceData->Ec1ActualLength[Index] = Length; + + // + // Release the lock. + // +/* WdfSpinLockRelease(WmiDeviceData->Ec1Lock); */ + + // SLAyer: PS #660. +/* if (oldBuffer != NULL) { */ +/* ExFreePool(oldBuffer); */ +/* } */ + } + + return; +} + + +void main() +{ + + EC1 Ec1; + PWMI_SAMPLE_DEVICE_DATA DData; + + // Initialize Ec1: + // PS #658 Ec1 = {0}; + Ec1.Xboolean = 0 ; + Ec1.Xuint8 = 0; + Ec1.Xuint16 = 0; + Ec1.Xuint32 = 0; + Ec1.Xuint64 = 0; + Ec1.Xint8 = 0; + Ec1.Xint16 = 0; + Ec1.Xint32 = 0; + Ec1.Xint64 = 0; + + DData = (PWMI_SAMPLE_DEVICE_DATA)malloc(sizeof(WMI_SAMPLE_DEVICE_DATA)); + if (DData != NULL) { + WmiSampSetEc1(DData, &Ec1, EC1_SIZE,0); + + // SLAyer: if we do this, we go UNSAFE. + //free(DData->Ec1[0]); + free(DData); + } + + return; +} + diff --git a/test/other/anonymous_union.c b/test/other/anonymous_union.c new file mode 100644 index 0000000..2a2db4f --- /dev/null +++ b/test/other/anonymous_union.c @@ -0,0 +1,21 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _T { + union { + int a; + struct { + char b; + char c; + short d; + }; + }; + void* e; +} T, *PT; + + +void main() +{ + T t; + PT pt = &t; + assert( pt != NULL ); +} diff --git a/test/other/array_access.c b/test/other/array_access.c new file mode 100644 index 0000000..a7924bc --- /dev/null +++ b/test/other/array_access.c @@ -0,0 +1,21 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Check that the A access is valid. +*/ + +#include "slayer.h" + +int A[4] = { 0, 1, 2, 3 }; + +void main() +{ + int x; + x = A[0]; + x = A[1]; + x = A[2]; + x = A[3]; + x = A[55]; /* We don't check array bounds */ + x = A[-2]; + x = -2[A]; +} diff --git a/test/other/array_arguments_heap.c b/test/other/array_arguments_heap.c new file mode 100644 index 0000000..f6eede3 --- /dev/null +++ b/test/other/array_arguments_heap.c @@ -0,0 +1,35 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + This is how t1394_EvtIoDeviceControl passes Arguments to t1394_AsyncWrite. +*/ +#include "slayer.h" + +struct T { + int Id ; + int Arguments[2] ; +}; + +void init (int iArguments[2]) +{ + struct T *p ; + p = (struct T *)malloc(sizeof(struct T)); + p->Id = 0; + p->Arguments[0] = iArguments[0] ; + p->Arguments[1] = iArguments[1] ; + free(p); +} + +void main() +{ + + struct T *t; + t = (struct T *)malloc(sizeof(struct T)); + t->Id = -1; + t->Arguments[0] = 0 ; + t->Arguments[1] = 1 ; + init(t->Arguments); + + { int x; x = t->Arguments[0]; } + free(t); +} diff --git a/test/other/array_arguments_stack.c b/test/other/array_arguments_stack.c new file mode 100644 index 0000000..c679cc5 --- /dev/null +++ b/test/other/array_arguments_stack.c @@ -0,0 +1,34 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + This is a simpler version of how t1394_EvtIoDeviceControl passes Arguments to + t1394_AsyncWrite. +*/ + +#include "slayer.h" + +struct T { + int Id ; + int Arguments[2] ; +}; + +void init (int iArguments[2]) +//void init (int *iArguments) +{ + struct T *p ; + p = (struct T *)malloc(sizeof(struct T)); + p->Id = 0; + p->Arguments[0] = iArguments[0] ; + p->Arguments[1] = iArguments[1] ; + free(p); +} + +void main() +{ + int Arguments[2] = { 10, 100 }; + init( Arguments ); + + { int x; x = Arguments[0]; } + +} + diff --git a/test/other/array_in_formal.c b/test/other/array_in_formal.c new file mode 100644 index 0000000..074e34e --- /dev/null +++ b/test/other/array_in_formal.c @@ -0,0 +1,78 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Flattening arrays to scalars is not OK if the array is in a formal. + Source of bug: kmdf 1394. +*/ + +// Un-comment to exhibit work-around. +//#define WORK_AROUND + + +// Basic types +#define ULONG unsigned long +#define ULONG_PTR unsigned long +#define LONG_PTR long +#define PAGE_SIZE 32 +#define UCHAR unsigned char + +// 1394 data structures +typedef struct _ALLOCATE_ADDRESS_RANGE { + // .... + ULONG nLength; + UCHAR Data[1]; +} ALLOCATE_ADDRESS_RANGE, *PALLOCATE_ADDRESS_RANGE; + +typedef struct _CONTEXT_BUNDLE +{ + PALLOCATE_ADDRESS_RANGE Context0; +} CONTEXT_BUNDLE; + + + +// Stub +int ADDRESS_AND_SIZE_TO_SPAN_PAGES(void* Va, ULONG Size) +{ + int x ; + return x; +} + + +kmdf1394_AllocateAddressRange ( + PALLOCATE_ADDRESS_RANGE +#ifdef WORK_AROUND + F_AAR +#else + AAR +#endif + ) +{ + void* pAsyncAddressData ; + int nPages; + CONTEXT_BUNDLE ContextBundle; +#ifdef WORK_AROUND + PALLOCATE_ADDRESS_RANGE AAR = F_AAR; +#endif + + ContextBundle.Context0 = AAR; + + // Access to nLength is fine. + pAsyncAddressData = malloc(AAR->nLength); + + // Access to Data causes SLAyer fe to think the formal AAR is a + // local whose address is taken. + nPages = ADDRESS_AND_SIZE_TO_SPAN_PAGES( + AAR->Data, + AAR->nLength); + + free(pAsyncAddressData); +} + + + +void main() +{ + ALLOCATE_ADDRESS_RANGE MainAAR; + kmdf1394_AllocateAddressRange(&MainAAR); +} + diff --git a/test/other/array_of_guids.c b/test/other/array_of_guids.c new file mode 100644 index 0000000..147cfea --- /dev/null +++ b/test/other/array_of_guids.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* + This is step5.tmh, line 1758. + +extern const __declspec(selectany) GUID WPP_LOCAL_TraceGuids[] = { {0x528b9093,0x3035,0xc568,{0x9e,0xfd,0xdd,0x0f,0xd9,0x14,0x13,0x35}}, }; + + Check that the WPP+Local_TraceGuids access is valid. +*/ + +#include "slayer.h" + +struct GUID { + int A; + int B; + int C; + int D[4]; +}; + +// a global guid +//struct GUID a_guid[] = { { 1, 2, 3, {100,101,102,103}}, } ; +// /\ write to a_guid[0].D[0],... + +struct GUID a_guid[1]; + +void main() +{ + a_guid[0].A = 1 ; + a_guid[0].B = 2 ; + a_guid[0].C = 3 ; + a_guid[0].D[0] = 100 ; + a_guid[0].D[1] = 101 ; + a_guid[0].D[2] = 102 ; + a_guid[0].D[3] = 103 ; +} diff --git a/test/other/array_of_structs.c b/test/other/array_of_structs.c new file mode 100644 index 0000000..4d4966d --- /dev/null +++ b/test/other/array_of_structs.c @@ -0,0 +1,135 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Test case for PS #659: initialize array of structs. + +*/ +#include "slayer.h" + +typedef void VOID_VOID(); + +typedef VOID_VOID *PFN_VOID_VOID; + +typedef struct _GUID { + unsigned long Data1; + unsigned short Data2; + unsigned short Data3; + unsigned char Data4[ 8 ]; +} GUID; +#define DEFINE_GUID(name, l, w1, w2, b1, b2, b3, b4, b5, b6, b7, b8) \ + /*EXTERN_C*/ const GUID /*DECLSPEC_SELECTANY*/ name \ + = { l, w1, w2, { b1, b2, b3, b4, b5, b6, b7, b8 } } + +#define PFN_WDF_WMI_INSTANCE_QUERY_INSTANCE PFN_VOID_VOID +#define PFN_WDF_WMI_INSTANCE_SET_INSTANCE PFN_VOID_VOID +#define PFN_WDF_WMI_INSTANCE_SET_ITEM PFN_VOID_VOID +#define PFN_WDF_WMI_INSTANCE_EXECUTE_METHOD PFN_VOID_VOID +#define ULONG long + +typedef struct _WMI_SAMPLE_INSTANCE_CONFIG { + GUID Guid; + ULONG MinSize; + PFN_WDF_WMI_INSTANCE_QUERY_INSTANCE EvtWmiInstanceQueryInstance; + PFN_WDF_WMI_INSTANCE_SET_INSTANCE EvtWmiInstanceSetInstance; + PFN_WDF_WMI_INSTANCE_SET_ITEM EvtWmiInstanceSetItem; + PFN_WDF_WMI_INSTANCE_EXECUTE_METHOD EvtWmiInstanceExecuteMethod; + +} WMI_SAMPLE_INSTANCE_CONFIG, *PWMI_SAMPLE_INSTANCE_CONFIG; + +void f() {} +void g() {} +void h() {} +void i() {} + +#define WmiSampleClass1Guid \ + { 0x1,0x1,0x1, { 0x1,0x1,0x1,0x1,0x1,0x1,0x1,0x1 } } +#define WmiSampleClass1_SIZE 0 +#define EvtWmiClass1DataQueryInstance f +#define EvtWmiClass1DataSetInstance g +#define EvtWmiClass1DataSetItem h +#define EvtWmiClass1ExecuteMethod i + +#define WmiSampleClass2Guid \ + { 0x2,0x2,0x2, { 0x2,0x2,0x2,0x2,0x2,0x2,0x2,0x2 } } +#define WmiSampleClass2_SIZE 0 +#define EvtWmiClass2DataQueryInstance f +#define EvtWmiClass2DataSetInstance g +#define EvtWmiClass2DataSetItem h +#define EvtWmiClass2ExecuteMethod i + +#define WmiSampleClass5Guid \ + { 0x5,0x5,0x5, { 0x5,0x5,0x5,0x5,0x5,0x5,0x5,0x5 } } +#define WmiSampleClass5_SIZE 0 +#define EvtWmiClass5DataQueryInstance f +#define EvtWmiClass5DataSetInstance g +#define EvtWmiClass5DataSetItem h +#define EvtWmiClass5ExecuteMethod i + +#define WmiSampleClass6Guid \ + { 0x6,0x6,0x6, { 0x6,0x6,0x6,0x6,0x6,0x6,0x6,0x6 } } +#define WmiSampleClass6_SIZE 0 +#define EvtWmiClass6DataQueryInstance f +#define EvtWmiClass6DataSetInstance g +#define EvtWmiClass6DataSetItem h +#define EvtWmiClass6ExecuteMethod i + +// Array of ints is fine. +int Numbers[] = { 0, 1, 2, 3, }; + +// Struct by itself is OK. +WMI_SAMPLE_INSTANCE_CONFIG AConfig = + { + WmiSampleClass1Guid, + WmiSampleClass1_SIZE, + EvtWmiClass1DataQueryInstance, + EvtWmiClass1DataSetInstance, + EvtWmiClass1DataSetItem, + EvtWmiClass1ExecuteMethod + } + ; + +// An array of Structs isn't. +WMI_SAMPLE_INSTANCE_CONFIG SampleInstanceConfig[] = { + { + WmiSampleClass1Guid, + WmiSampleClass1_SIZE, + EvtWmiClass1DataQueryInstance, + EvtWmiClass1DataSetInstance, + EvtWmiClass1DataSetItem, + EvtWmiClass1ExecuteMethod + }, + +/* { */ +/* WmiSampleClass2Guid, */ +/* WmiSampleClass2_SIZE, */ +/* EvtWmiClass2DataQueryInstance, */ +/* EvtWmiClass2DataSetInstance, */ +/* NULL, */ +/* NULL */ +/* }, */ + +/* { */ +/* WmiSampleClass5Guid, */ +/* WmiSampleClass5_SIZE, */ +/* EvtWmiClass5DataQueryInstance, */ +/* EvtWmiClass5DataSetInstance, */ +/* NULL, */ +/* NULL */ +/* }, */ + +/* { */ +/* WmiSampleClass6Guid, */ +/* WmiSampleClass6_SIZE, */ +/* EvtWmiClass6DataQueryInstance, */ +/* EvtWmiClass6DataSetInstance, */ +/* NULL, */ +/* NULL */ +/* }, */ +}; + +void main() +{ + int size; + size = AConfig.MinSize; + SampleInstanceConfig[0].MinSize = size; +} diff --git a/test/other/assume_assert.c b/test/other/assume_assert.c new file mode 100644 index 0000000..a178a05 --- /dev/null +++ b/test/other/assume_assert.c @@ -0,0 +1,17 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" +#include + +#pragma warning(disable:4700) /* Using uninitialized memory */ +#pragma warning(disable:6001) /* Using uninitialized memory */ + +void main() { + int i; + assume(i > 0); + assert(i > 0); + i--; + assert(i); /* UNSAFE */ + _SLAyer_unreachable(); + _SLAyer_error(); +} diff --git a/test/other/backjump.c b/test/other/backjump.c new file mode 100644 index 0000000..81fd899 --- /dev/null +++ b/test/other/backjump.c @@ -0,0 +1,16 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Structured gotos. + */ + +#include "slayer.h" + +void main() { + int x, y; + L: y = 0; + if(y==0) return; + FAIL ; + x = 0; + goto L; +} diff --git a/test/other/bitfield.c b/test/other/bitfield.c new file mode 100644 index 0000000..7a93365 --- /dev/null +++ b/test/other/bitfield.c @@ -0,0 +1,23 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _T { + unsigned char a : 1; + unsigned char : 2; /* 2 bits of padding */ + unsigned char b : 2; + unsigned char : 0; /* pad to next char/byte boundary */ + unsigned char c : 3; + unsigned long : 0; /* pad to next long/word boundary */ + unsigned char d : 4; +} T, *PT; + +void main() +{ + T t; + t.a = 0; + t.b = 3; + t.c = 2; + t.d = 4; + assert( t.a != t.d ); + assert( t.a != t.c ); + assert( t.a != t.b ); +} diff --git a/test/other/bool_to_int.c b/test/other/bool_to_int.c new file mode 100644 index 0000000..276b024 --- /dev/null +++ b/test/other/bool_to_int.c @@ -0,0 +1,14 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + C's bool representation. +*/ + +#include "slayer.h" + +int main() { + int four, eq_four; + four = 4; + eq_four = (four == 4); + FAIL_IF( eq_four != 1 ); +} diff --git a/test/other/call.c b/test/other/call.c new file mode 100644 index 0000000..5d8698d --- /dev/null +++ b/test/other/call.c @@ -0,0 +1,19 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Unique ids over fun calls. +*/ + +#include "slayer.h" + +void f() { + int x = 1; + return; +} + +void main() { + int x = 0; + f(); + FAIL_IF(x!=0); + return; +} diff --git a/test/other/call_arg.c b/test/other/call_arg.c new file mode 100644 index 0000000..8dce89d --- /dev/null +++ b/test/other/call_arg.c @@ -0,0 +1,25 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Access local/global through fun call. +*/ + +#include "slayer.h" + +int g; + +void f(int a, int *z) { + int y = a; + + FAIL_IF( y!=*z ); + *z = g; + y = 13; + return; +} + +void main() { + int x = 0; + f(0, &x); + FAIL_IF( x!=g ); + return; +} diff --git a/test/other/call_arg_unique.c b/test/other/call_arg_unique.c new file mode 100644 index 0000000..56e6ec3 --- /dev/null +++ b/test/other/call_arg_unique.c @@ -0,0 +1,19 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + We have a fun call convention to have unique actuals. +*/ + +void f(int a, int b) { + int y = a + b; + return; +} + +void main() { + int x = 0; + int y = 1; + + f(x,x); // Should become f(x1,x2) + f(x,y); // Should become f(x3,y1) + return; +} diff --git a/test/other/cast.c b/test/other/cast.c new file mode 100644 index 0000000..f923b25 --- /dev/null +++ b/test/other/cast.c @@ -0,0 +1,52 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +void main() { + int i; + float* fp1; + float* fp2; + float f1; + float f2; + float f3; + float f4; + + (int*)(float*)fp1 = &i; + /* compiles to: + lea eax, DWORD PTR _i$[ebp] + mov DWORD PTR _fp1$[ebp], eax + */ + fp2 = (float*)(int*)(&i); + /* compiles to: + lea ecx, DWORD PTR _i$[ebp] + mov DWORD PTR _fp2$[ebp], ecx + */ + assert(fp1 == fp2); /* SAFE */ + + + (int)(float)f1 = i; + /* compiles to: + mov ecx, DWORD PTR _i$[ebp] + mov DWORD PTR _f1$[ebp], ecx + */ + f2 = (float)(int)i; + /* compiles to: + cvtsi2ss xmm0, DWORD PTR _i$[ebp] + movss DWORD PTR _f2$[ebp], xmm0 + */ + + + (int*)(int)(float)f3 = &i; + /* compiles to: + lea edx, DWORD PTR _i$[ebp] + mov DWORD PTR _f3$[ebp], edx + */ + f4 = (float)(int)(int*)(&i); + /* compiles to: + lea eax, DWORD PTR _i$[ebp] + cvtsi2ss xmm0, eax + movss DWORD PTR _f4$[ebp], xmm0 + */ + + assert(f1 == f2 || f3 == f4); /* UNSAFE */ +} diff --git a/test/other/cast_1394.c b/test/other/cast_1394.c new file mode 100644 index 0000000..200c25f --- /dev/null +++ b/test/other/cast_1394.c @@ -0,0 +1,47 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Code from kmdf_vdev_api, line 194. +*/ + +#define USHORT unsigned short +#define ULONG unsigned long +#define PVOID void* +#define UCHAR unsigned char + + +typedef struct _ADDRESS_OFFSET { + USHORT Off_High; + ULONG Off_Low; +} ADDRESS_OFFSET, *PADDRESS_OFFSET; + +typedef struct _GET_LOCAL_HOST_INFO6 { + ADDRESS_OFFSET CsrBaseAddress; + ULONG CsrDataLength; + PVOID CsrDataBuffer; +} GET_LOCAL_HOST_INFO6, *PGET_LOCAL_HOST_INFO6; + +typedef struct _GET_LOCAL_HOST_INFORMATION { + ULONG Status; + ULONG nLevel; + ULONG ulBufferSize; + UCHAR Information[1]; +} GET_LOCAL_HOST_INFORMATION, *PGET_LOCAL_HOST_INFORMATION; + + +void f(PGET_LOCAL_HOST_INFORMATION GetLocalHostInfo) +{ + GET_LOCAL_HOST_INFO6 LocalHostInfo6 = {0}; + ((PGET_LOCAL_HOST_INFO6)GetLocalHostInfo->Information)->CsrDataLength = \ + LocalHostInfo6.CsrDataLength; +} + +void main() +{ + GET_LOCAL_HOST_INFORMATION GetLocalHostInfo; + GET_LOCAL_HOST_INFO6 LocalHostInfo6; + + (PGET_LOCAL_HOST_INFO6)GetLocalHostInfo.Information = &LocalHostInfo6; + + f(&GetLocalHostInfo); +} diff --git a/test/other/cast_bt_types.c b/test/other/cast_bt_types.c new file mode 100644 index 0000000..63c2594 --- /dev/null +++ b/test/other/cast_bt_types.c @@ -0,0 +1,29 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +struct I { int i; }; +struct IJ { int i; int j; }; + +void main() +{ + int *x; + struct I *pi; + struct IJ *pij; + + x = malloc(sizeof(int)); + // x->(int) [] + + pi = (struct I*)x; + pi->i = 32; + // x->(I) [i:32] + + pij = (struct IJ*)x; + pij->i = 10; + pij->j = 100; // UNSAFE! + // x->(IJ) [i:10;j:100] + + x = (int*)pij; + free(x); + +} diff --git a/test/other/cast_guard_implicit.c b/test/other/cast_guard_implicit.c new file mode 100644 index 0000000..9bf52dc --- /dev/null +++ b/test/other/cast_guard_implicit.c @@ -0,0 +1,12 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +int a; + +void main() { + int x; + x = &a; + assert(x != &a); + return; +} diff --git a/test/other/cast_guard_int.c b/test/other/cast_guard_int.c new file mode 100644 index 0000000..a137493 --- /dev/null +++ b/test/other/cast_guard_int.c @@ -0,0 +1,12 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +int a; + +void main() { + int x; + x = &a; + assert(x == (int)&a); + return; +} diff --git a/test/other/cast_guard_ptr.c b/test/other/cast_guard_ptr.c new file mode 100644 index 0000000..4f1c0d4 --- /dev/null +++ b/test/other/cast_guard_ptr.c @@ -0,0 +1,12 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +int a; + +void main() { + int x; + x = &a; + assert((int*)x == &a); + return; +} diff --git a/test/other/compound_assignment.c b/test/other/compound_assignment.c new file mode 100644 index 0000000..c6587ea --- /dev/null +++ b/test/other/compound_assignment.c @@ -0,0 +1,27 @@ + +#include "SLAyer.h" + +int *x; +int *y; + +int *f() +{ + free(y); + *x += 1; + return x; +} + +void main() +{ + x = (int*)malloc(sizeof(int)); + y = (int*)malloc(sizeof(int)); + *x = 0; + + *(f()) += 1; + // Should only evaluate *(f()) once. + // Integers are too abstracted by SLAyer to prove this, + // added free(y) to track if it is called twice. + //assert(*x == 2); + + free(x); +} diff --git a/test/other/containing_record.c b/test/other/containing_record.c new file mode 100644 index 0000000..faeca70 --- /dev/null +++ b/test/other/containing_record.c @@ -0,0 +1,42 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Test frontend's treatment of containing_record. +*/ + +#include "slayer.h" + +typedef void *HANDLE; +typedef unsigned char* PCHAR; + +typedef struct _LIST_ENTRY { + struct _LIST_ENTRY *Flink; + struct _LIST_ENTRY *Blink; +} LIST_ENTRY, *PLIST_ENTRY; + +typedef struct _ISOCH_RESOURCE_DATA { + long long Size; + long long Size1; + PCHAR Name; + LIST_ENTRY IsochResourceList; + HANDLE hResource; +} ISOCH_RESOURCE_DATA, *PISOCH_RESOURCE_DATA; + +int main() +{ + PISOCH_RESOURCE_DATA IsochResourceData; + PISOCH_RESOURCE_DATA cr, co; + PLIST_ENTRY listEntry; + + IsochResourceData = (PISOCH_RESOURCE_DATA)malloc(sizeof(ISOCH_RESOURCE_DATA)); + listEntry = &(IsochResourceData->IsochResourceList); + + cr = CONTAINING_RECORD(listEntry, ISOCH_RESOURCE_DATA, IsochResourceList); + co = container_of(listEntry, ISOCH_RESOURCE_DATA, IsochResourceList); + + assert( cr == co ); + assert( cr == IsochResourceData ); + + free(cr); + return 0; +} diff --git a/test/other/control_guard.c b/test/other/control_guard.c new file mode 100644 index 0000000..a73a1ee --- /dev/null +++ b/test/other/control_guard.c @@ -0,0 +1,11 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Statement inside an Expr. +*/ + +void main() { + int x = 0; + if(x++, x) { x = 42; } + return; +} diff --git a/test/other/copy_struct_on_heap.c b/test/other/copy_struct_on_heap.c new file mode 100644 index 0000000..e573af8 --- /dev/null +++ b/test/other/copy_struct_on_heap.c @@ -0,0 +1,55 @@ + /* + Copyright (c) Microsoft Corporation. All rights reserved. + + Check that the fe changes the + OutBufferSTBD = pFdo->StdToasterBusData + copy to field-wise + OutBufferSTBD->ErrorCount = pFdo->StdToasterBusData.ErrorCount; + ... + copies. + + Filed as bug PS#620. +*/ + +#define ULONG long + +typedef struct _ToasterBusInformation +{ + ULONG ErrorCount; + ULONG DebugPrintLevel; + ULONG Pad; +} ToasterBusInformation, *PToasterBusInformation; + +typedef ToasterBusInformation TOASTER_BUS_WMI_STD_DATA, * PTOASTER_BUS_WMI_STD_DATA; + +typedef struct _FDO_DEVICE_DATA +{ + ULONG X ; + TOASTER_BUS_WMI_STD_DATA StdToasterBusData; + +} FDO_DEVICE_DATA, *PFDO_DEVICE_DATA; + + + +void main() +{ + PFDO_DEVICE_DATA pFdo; + void *OutBufferX; + void *OutBufferSTBD; + ULONG *p ; + + pFdo = (PFDO_DEVICE_DATA)malloc(sizeof(FDO_DEVICE_DATA)); + OutBufferX = malloc(sizeof(FDO_DEVICE_DATA)); + OutBufferSTBD = malloc(sizeof(FDO_DEVICE_DATA)); + + // Copying a scalar field. + * (ULONG*) OutBufferX = pFdo->X; + + // Copy a 'struct' field. + * (PTOASTER_BUS_WMI_STD_DATA) OutBufferSTBD = pFdo->StdToasterBusData; + + free(OutBufferSTBD); + free(OutBufferX); + free(pFdo); + return; +} diff --git a/test/other/copy_struct_on_stack.c b/test/other/copy_struct_on_stack.c new file mode 100644 index 0000000..8847dae --- /dev/null +++ b/test/other/copy_struct_on_stack.c @@ -0,0 +1,20 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + The fe needs to move s1, s2 to the heap and change the s1=s2 copy + to field-wise copy s1.x=s2.x;... . +*/ + +struct S { + int x; + int y; + char z; +}; + +void main() +{ + struct S s1 = {1,2,'3'}; + struct S s2 = {4,5,'6'}; + + s1 = s2; +} diff --git a/test/other/dead_code.c b/test/other/dead_code.c new file mode 100644 index 0000000..8ea541c --- /dev/null +++ b/test/other/dead_code.c @@ -0,0 +1,14 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Frontend drops deadcode. +*/ + +#include "slayer.h" + +void main() { + int x; + x = 0; + return; + FAIL; +} diff --git a/test/other/deref_NULL2.c b/test/other/deref_NULL2.c new file mode 100644 index 0000000..6f8847d --- /dev/null +++ b/test/other/deref_NULL2.c @@ -0,0 +1,7 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +int main() { + int x; + int *y = 0; + x = *y; +} diff --git a/test/other/deref_ZERO.c b/test/other/deref_ZERO.c new file mode 100644 index 0000000..60301ad --- /dev/null +++ b/test/other/deref_ZERO.c @@ -0,0 +1,8 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +void** ZERO = 0; + +void main() { + *ZERO = (void*)1; + return; +} diff --git a/test/other/deref_via_call.c b/test/other/deref_via_call.c new file mode 100644 index 0000000..00e456a --- /dev/null +++ b/test/other/deref_via_call.c @@ -0,0 +1,36 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + deref_via_call.c : assign into a local, but by passing it's address down a + chain of function calls. + + This program should be safe. +*/ + +#include + +int g; + +void set_to_global_addr(int*** ppi) +{ + **ppi = &g; +} + +void set_to_global_addr_wrapper(int** pi) +{ + int** l_pi = pi; + int*** ppi; + ppi = &l_pi; + set_to_global_addr(ppi); +} + +void main () +{ + int **p = (int*) malloc (sizeof(int)); + *p = NULL; + set_to_global_addr_wrapper(p); + + assert (*p != NULL); + + free(p); +} diff --git a/test/other/deref_via_call2.c b/test/other/deref_via_call2.c new file mode 100644 index 0000000..03300a5 --- /dev/null +++ b/test/other/deref_via_call2.c @@ -0,0 +1,49 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* + deref_via_call2.c : assign into a local, but by passing it's address down a + chain of function calls. + + This program should be safe: it should never assign *0=0. + + This was a test case to check frontend_slam's local declaration correctness: + parent functions used to declare their child functions locals. + + This is the same as deref_via_call.c except that the address of the formal + paramater of f is not taken. +*/ + +#include + +int a,b,c; + +int uninit_g_x ; +int* uninit_g_py ; +int uninit_g_z ; + +void g(int*** g_ppi) +{ + **g_ppi = &a; +} + +void f(int** _f_pi) +{ + int** f_pi = _f_pi; + int*** f_ppi; + f_ppi = &f_pi; + g(f_ppi); +} + +void main () +{ + int** p = (int*) malloc (sizeof(int)); + *p = &b; + f(p); + *p = &c; + f(p); + *p = NULL; + f(p); + + assert(*p != NULL); + return; +} diff --git a/test/other/deref_via_call3.c b/test/other/deref_via_call3.c new file mode 100644 index 0000000..eec9f18 --- /dev/null +++ b/test/other/deref_via_call3.c @@ -0,0 +1,28 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + deref_via_call.c : assign into a local, but by passing it's address down a + chain of function calls. + + This program should be safe. +*/ + +#include + +int a,b,c; + +void add10(int* ppi) +{ + *ppi = *ppi + 10; +} + +int add10_wrapper(int pi) +{ + add10(&pi); + return pi; +} + +void main () +{ + add10_wrapper(1); +} diff --git a/test/other/dynamic_size_array.c b/test/other/dynamic_size_array.c new file mode 100644 index 0000000..af37be9 --- /dev/null +++ b/test/other/dynamic_size_array.c @@ -0,0 +1,20 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +void main() { + int n; + int* a; + int i; + + n = n % 16; + a = malloc(n * sizeof(int)); + + for(i=0; iZ; + free(t); +} diff --git a/test/other/global_struct_fields.c b/test/other/global_struct_fields.c new file mode 100644 index 0000000..9c79895 --- /dev/null +++ b/test/other/global_struct_fields.c @@ -0,0 +1,30 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Assignment into struct fields. +*/ + +#include "slayer.h" + +struct Globals +{ + int* AssocClassList; + int* NumAssocClass; +}; + + +struct Globals g; + +void cpy (int* src, int* dest) +{ + FAIL_IF (src == dest) ; + return; +} + +main() +{ + int dummy; + g.AssocClassList = NULL; + g.NumAssocClass = &dummy; + cpy(g.AssocClassList, g.NumAssocClass); +} diff --git a/test/other/global_var.c b/test/other/global_var.c new file mode 100644 index 0000000..5578d87 --- /dev/null +++ b/test/other/global_var.c @@ -0,0 +1,15 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Global variable init. +*/ + +#include "slayer.h" + +int x = 0; + +void main() { + int y = x; + FAIL_IF (y!=0) ; + return; +} diff --git a/test/other/globals_per_proc.c b/test/other/globals_per_proc.c new file mode 100644 index 0000000..9a0808c --- /dev/null +++ b/test/other/globals_per_proc.c @@ -0,0 +1,39 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Run these with 'inline' set to false. +*/ + +int x,y,z,u,v; + +// f uses {x} +void f() +{ + int a; + int b; + int c; + // assert: x->_. (y->_ should have been framed away.) + a = x; + c = &b; +} + +// g uses {y,x} +void g() +{ + int b = y; + // assert: y->_ * x->_. (z->_ should have been framed away.) + f(); +} + +// h uses {z,y,x} +void h() +{ + int c=z; + // assert: z->_ * y->_ * x->_ + g(); +} + +void main() +{ + h(); +} diff --git a/test/other/icall.c b/test/other/icall.c new file mode 100644 index 0000000..6f36d7d --- /dev/null +++ b/test/other/icall.c @@ -0,0 +1,37 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +typedef struct _T { + int a; + int b; + int c; +} T; + +// pointer to a T*->int* function. +typedef int* (*FP) (T*); + +int* add_b (T* x) { + return &(x->b); +} + +int* add_c (T* x) { + return &(x->c); +} + +void main() { + T t; + int* x; + int* y; + FP fp; + + fp = &add_b; + x = &(t.a); + y = (*fp)(x); // Even if we write fp(x), cl will coerce this to (*fp)(x). + assert(x != y); + + fp = &add_c; + x = &(t.a); + y = (*fp)(x); + assert(x != y); +} diff --git a/test/other/icall_with_global1.c b/test/other/icall_with_global1.c new file mode 100644 index 0000000..80c5738 --- /dev/null +++ b/test/other/icall_with_global1.c @@ -0,0 +1,45 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +int x; + +int y; + +// pointer to two function types. +typedef int (*FP) (); +typedef void (*FP2) (); + +void add_b () { + x ++; +} + +int add_c () { + return y + 1; +} + +FP fp; +FP2 fp2; + +//Access {fp, y} +//Modifies nothing. +void f() { + int z; + z = (*fp)(); +} + +//Accesses {fp2, x} +//Writes x (if modified globals are not heapified) +void g() { + (*fp2)(); +} + +//Accesses (fp2,fp,x,y,add_c,add_b) +//Writes fp,fp2,x (without heapification of globals) +void main() { + fp = &add_c; + fp2 = &add_b; + + f(); + g(); +} diff --git a/test/other/icall_with_global2.c b/test/other/icall_with_global2.c new file mode 100644 index 0000000..6de10f1 --- /dev/null +++ b/test/other/icall_with_global2.c @@ -0,0 +1,48 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +int x; + +int y; + +// pointer to two function types. +typedef void (*FP) (void*); +typedef void (*FP2) (int*); + +void add_b (void * f) { + x ++; +} + +void add_c (int * f) { + y ++; +} + +FP2 fp; +FP fp2; + +//Access {fp, y} +//Writes { y} (without heapification) +void f() { + int z; + (*fp)(&z); +} + +//Accesses {fp2, x} +//Writes x (if modified globals are not heapified) +void g() { + int z; + void * p; + p = (void*) &z; + (*fp2)(p); +} + +//Accesses (fp2,fp,x,y,add_c,add_b) +//Writes fp,fp2,x (without heapification of globals) +void main() { + fp = &add_c; + fp2 = &add_b; + + f(); + g(); +} diff --git a/test/other/icall_with_global3.c b/test/other/icall_with_global3.c new file mode 100644 index 0000000..98badbc --- /dev/null +++ b/test/other/icall_with_global3.c @@ -0,0 +1,46 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +int x; + +int y; + +// pointer to two function types. +typedef void (*FP) (int*); +typedef void (*FP2) (int*); + +void add_b (int * f) { + x ++; +} + +void add_c (int * f) { + y ++; +} + +FP2 fp; +FP fp2; + +//Access {fp, y} with type approximation also {x} +//Writes { y} (without heapification) +void f() { + int z; + (*fp)(&z); +} + +//Accesses {fp2, x} with type approximation also {y} +//Writes x (if modified globals are not heapified) +void g() { + int z; + (*fp2)(&z); +} + +//Accesses (fp2,fp,x,y,add_c,add_b) +//Writes fp,fp2,x (without heapification of globals) +void main() { + fp = &add_c; + fp2 = &add_b; + + f(); + g(); +} diff --git a/test/other/icall_with_global4.c b/test/other/icall_with_global4.c new file mode 100644 index 0000000..f4ffc88 --- /dev/null +++ b/test/other/icall_with_global4.c @@ -0,0 +1,54 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +int x; + +int y; + +// pointer to two function types. +typedef void (*FP) (int*); +typedef void (*FP2) (int*); + +void add_b (int * f) { + x ++; +} + +void add_c (int * f) { + y ++; +} + +FP2 fp; +FP fp2; + +//Access {fp, y} +// with type approximation or (flow insensitive) may alias also {x} +//Writes { y} (without heapification) +// with type approximation or (flow insensitive) may alias also {x} +void f() { + int z; + (*fp)(&z); +} + +//Accesses {fp, x} +// with type approximation or (flow insensitive) may alias also {y} +//Writes x (if modified globals are not heapified) +// with type approximation or (flow insensitive) may alias also {y} +void g() { + int z; + (*fp)(&z); +} + +//Accesses (fp2,fp,x,y,add_c,add_b) +//Writes fp,fp2,x (without heapification of globals) +void main() { + fp = &add_c; + fp2 = &add_b; + + f(); + + fp = &add_b; + fp2 = &add_c; + + g(); +} diff --git a/test/other/if.c b/test/other/if.c new file mode 100644 index 0000000..0dbb7cf --- /dev/null +++ b/test/other/if.c @@ -0,0 +1,9 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +void main() { + int x, y; + y = 0; + if(x==y) { x = 0; } else { x = 1; } + y = 5; + return; +} diff --git a/test/other/if_integer.c b/test/other/if_integer.c new file mode 100644 index 0000000..3960225 --- /dev/null +++ b/test/other/if_integer.c @@ -0,0 +1,33 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Update x->car if n. +*/ + +#include "slayer.h" + +typedef struct cell cell; +struct cell { + int car; + cell* cdr; +}; + +int main() { + int n; + cell *x; + + n = 5; + x = (cell*)malloc(sizeof(cell)); + x->car = 0; + + if (n) { + x->car = x->car + 1; + x->cdr = 0; + } + + assert( x->car == 1 ); + + free(x); + + return 0; +} diff --git a/test/other/if_pointer.c b/test/other/if_pointer.c new file mode 100644 index 0000000..b7db6a1 --- /dev/null +++ b/test/other/if_pointer.c @@ -0,0 +1,28 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Update x->car if x. +*/ + +#include "slayer.h" + +typedef struct cell cell; +struct cell { + int car; + cell* cdr; +}; + +int main() { + cell *x ; + + if (x) { + x->car = x->car * 2 ; + x->cdr = 0; + } + else { + x = (cell*)malloc(sizeof(cell)); + x->car = 0; + } + + return 0; +} diff --git a/test/other/ifguard.c b/test/other/ifguard.c new file mode 100644 index 0000000..21d31d6 --- /dev/null +++ b/test/other/ifguard.c @@ -0,0 +1,13 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +void main() { + int x = 0, y = 0; + if(x==0) { + FAIL_IF(y != x); + return; + } + FAIL ; + return; +} diff --git a/test/other/inline_args.c b/test/other/inline_args.c new file mode 100644 index 0000000..c41b58c --- /dev/null +++ b/test/other/inline_args.c @@ -0,0 +1,47 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + compare is inlineable. + Check that: + 1. args passed correctly; + 2. result returned correctly; + 3. we continue to the right place. +*/ + +#include "slayer.h" + +int a, b, c, d, e, f; + + +void* compare (void* x, void* y, void* z) +{ + void* result; + + if (x==y) goto xy_eq; + else if (y==z) goto yz_eq; + else goto no_eq; + + xy_eq: result=&a; return result; + + yz_eq: result=&b; return result; + + no_eq: result=&c; return result; +} + +void main() +{ + int *x, *y, *z; + void* result; + + x=&d; y=&d; z=&f; + result = compare (x,y,z); + if (result != &a) FAIL; + + x=&d; y=&e; z=&e; + result = compare (x,y,z); + if (result != &b) FAIL; + + x=&d; y=&e; z=&f; + result = compare (x,y,z); + if (result != &c) FAIL; +} diff --git a/test/other/inline_criteria.c b/test/other/inline_criteria.c new file mode 100644 index 0000000..b2b77f1 --- /dev/null +++ b/test/other/inline_criteria.c @@ -0,0 +1,64 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + inline criteria. +*/ + +/* vanilla is inlineable 'cos a leaf function with no loops. */ +void vanilla(void) +{ + int x; + x = x+x; + if (x) x--; + else x++; +} + +/* vanilla_parent inlineable, either because vanilla has been inlined + first and vanilla_parent is now a leaf, or because it's just a thin + wrapper on a proc call. */ +void vanilla_parent(void) +{ + int x; + x = x + 42; + vanilla(); + x = x % 4; +} + +// looper is not inlineable as it contains a loop. +void looper(void) +{ + int i, x; + for (i=0; i<10; i++) x=x*10; +} + +// looper_parent is inlineable, but looper isn't. +void looper_parent(void) +{ + int x ; + x = x + 22 ; + looper(); + x = x - 2 ; +} + +// frec not inlineable: calls itself. +void frec (int x) +{ + if (x==0) return; + else frec(x-1); +} + + +void main() +{ + // inline + vanilla_parent(); + // no inline + looper(); + // inline parent + looper_parent(); + // no inline + frec(99); + +} + + diff --git a/test/other/mainret.c b/test/other/mainret.c new file mode 100644 index 0000000..72ac77f --- /dev/null +++ b/test/other/mainret.c @@ -0,0 +1,5 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +int main() { + return -1; +} diff --git a/test/other/malloc.c b/test/other/malloc.c new file mode 100644 index 0000000..ce4804d --- /dev/null +++ b/test/other/malloc.c @@ -0,0 +1,10 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +int main() { + int *x = (int*)malloc(sizeof(int)); + int *y = (int*)malloc(sizeof(int)); + *x = 42; + *y = 13; +} diff --git a/test/other/malloc_free.c b/test/other/malloc_free.c new file mode 100644 index 0000000..7dfe24b --- /dev/null +++ b/test/other/malloc_free.c @@ -0,0 +1,12 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +int main() { + int *x = (int*)malloc(sizeof(int)); + int *y = (int*)malloc(sizeof(int)); + *x = 42; + free(x); + *y = 13; + free(y); +} diff --git a/test/other/malloc_free_struct.c b/test/other/malloc_free_struct.c new file mode 100644 index 0000000..660a993 --- /dev/null +++ b/test/other/malloc_free_struct.c @@ -0,0 +1,16 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct cell cell; +struct cell { + int car; + cell* cdr; +}; + +int main() { + cell *x = (cell*)malloc(sizeof(cell)); + x->car = 42; + x->cdr = 0; + free(x); +} diff --git a/test/other/malloc_struct.c b/test/other/malloc_struct.c new file mode 100644 index 0000000..c7b1044 --- /dev/null +++ b/test/other/malloc_struct.c @@ -0,0 +1,15 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct cell cell; +struct cell { + int car; + cell* cdr; +}; + +int main() { + cell *x = (cell*)malloc(sizeof(cell)); + x->car = 42; + x->cdr = 0; +} diff --git a/test/other/multireturn.c b/test/other/multireturn.c new file mode 100644 index 0000000..ae73d21 --- /dev/null +++ b/test/other/multireturn.c @@ -0,0 +1,14 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +int f() { + int x, y; + x = 0; + if(x==y) return 0; + x = 4; + y = x; + return 1; +} + +int main() { + f(); +} diff --git a/test/other/nested_struct.c b/test/other/nested_struct.c new file mode 100644 index 0000000..aaf6334 --- /dev/null +++ b/test/other/nested_struct.c @@ -0,0 +1,21 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _cell { + int car; + struct _cell* cdr; + struct foo { + int bar; + } baz; +} cell; + +void main() { + cell* x = (cell*)malloc(sizeof(cell)); + cell y; + (*x).car = 1; + y.car = 2; + y.baz.bar = 42; + (*x).baz.bar = 21; + return; +} diff --git a/test/other/pointer_subtraction.c b/test/other/pointer_subtraction.c new file mode 100644 index 0000000..4e50fab --- /dev/null +++ b/test/other/pointer_subtraction.c @@ -0,0 +1,8 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +main() { + long *a; + long *b; + long *c; + c = a - b; +} diff --git a/test/other/reachable_globals.c b/test/other/reachable_globals.c new file mode 100644 index 0000000..e993303 --- /dev/null +++ b/test/other/reachable_globals.c @@ -0,0 +1,43 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +struct list +{ + int data; + struct list * next; +}; + +struct list* l; +struct list* m; + +// {l,c0,c1,c2} should be in f's footprint. +// m shouldn't be. +void f() +{ + struct list *x = l; +} + +void main() +{ + struct list *c0, *c1, *c2; + + m = (struct list*) malloc(sizeof(struct list)); + + c2 = (struct list*) malloc(sizeof(struct list)); + c2->data = 2; + c2->next = (struct list *)NULL; + + c1 = (struct list*) malloc(sizeof(struct list)); + c1->data = 1; + c1->next = c2; + + c0 = (struct list*) malloc(sizeof(struct list)); + c0->data = 0; + c0->next = c1; + + // loc: c0 c1 c2 + // content: (0,c1) (1,c2) (2,NULL) + l = c0; + f(); +} diff --git a/test/other/rep_3_f_int_star.c b/test/other/rep_3_f_int_star.c new file mode 100644 index 0000000..76de36e --- /dev/null +++ b/test/other/rep_3_f_int_star.c @@ -0,0 +1,15 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +int * f() { + return malloc(sizeof(int)); +} + +void main(void) { + int * x, * x1, * x2; + + x = f(); + x1 = f(); + x1 = f(); + + free(x); +} diff --git a/test/other/rep_4_f_int_star.c b/test/other/rep_4_f_int_star.c new file mode 100644 index 0000000..5cecfcb --- /dev/null +++ b/test/other/rep_4_f_int_star.c @@ -0,0 +1,16 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +int * f() { + return malloc(sizeof(int)); +} + +void main(void) { + int * x, * x1, * x2; + + x = f(); + x1 = f(); + x1 = f(); + x1 = f(); + + free(x); +} diff --git a/test/other/rep_4_f_void_star.c b/test/other/rep_4_f_void_star.c new file mode 100644 index 0000000..a204690 --- /dev/null +++ b/test/other/rep_4_f_void_star.c @@ -0,0 +1,16 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +void * f(int size) { + return malloc(size); +} + +void main(void) { + void * x, * x1, * x2; + + x = f(8); + x1 = f(8); + x1 = f(8); + x1 = f(8); + + free(x); +} diff --git a/test/other/return.c b/test/other/return.c new file mode 100644 index 0000000..6ffd0ff --- /dev/null +++ b/test/other/return.c @@ -0,0 +1,15 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +int a; + +int* f(int* x) { + return x; +} + +void main() { + int* x; + x = f(&a); + assert(x == &a); +} diff --git a/test/other/return_struct.c b/test/other/return_struct.c new file mode 100644 index 0000000..ee3dfbc --- /dev/null +++ b/test/other/return_struct.c @@ -0,0 +1,16 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _S { + int a; + int b; +} S; + +S f() { + S t; + return t; +} + +main() { + S s; + s = f(); +} diff --git a/test/other/sized_array_simple.c b/test/other/sized_array_simple.c new file mode 100644 index 0000000..1c2e758 --- /dev/null +++ b/test/other/sized_array_simple.c @@ -0,0 +1,20 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Declare a fixed size array. +*/ + +void f(int x) +{ + int i; + int a[10]; + for (i=0; i<10; i++) + a[i] = x + i; +} + + +void main() +{ + int x = 42; + f(x); +} diff --git a/test/other/small_ites4.c b/test/other/small_ites4.c new file mode 100644 index 0000000..61d544f --- /dev/null +++ b/test/other/small_ites4.c @@ -0,0 +1,148 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Many small ite-s. (Taken from SLAyer/test/T2/Skin.c.) + Really hits SLAyer perf. +*/ + +// Initialization macros +#define GRANULARITY 3 + +#define INIT_VAR(V) \ + if (V > GRANULARITY) { V = GRANULARITY; } \ + else if (V < 0) { V = 0; } + + +int main() { + + // Variables. + int wntext0, wntext0_new; + int frizzled0, frizzled0_new; + int dsh0, dsh0_new; + int axin0, axin0_new; + int bcat0, bcat0_new; + int gt1_0, gt1_0_new; + int gt2_0, gt2_0_new; + int delta0, delta0_new; + int deltaext0, deltaext0_new; + int notchic0, notchic0_new; + int p21_0, p21_0_new; + int wnt0, wnt0_new; + + int wntext1, wntext1_new; + int frizzled1, frizzled1_new; + int dsh1, dsh1_new; + int axin1, axin1_new; + int bcat1, bcat1_new; + int gt1_1, gt1_1_new; + int gt2_1, gt2_1_new; + int delta1, delta1_new; + int deltaext1, deltaext1_new; + int notchic1, notchic1_new; + int p21_1, p21_1_new; + int wnt1, wnt1_new; + + int wntext2, wntext2_new; + int frizzled2, frizzled2_new; + int dsh2, dsh2_new; + int axin2, axin2_new; + int bcat2, bcat2_new; + int gt1_2, gt1_2_new; + int gt2_2, gt2_2_new; + int delta2, delta2_new; + int deltaext2, deltaext2_new; + int notchic2, notchic2_new; + int p21_2, p21_2_new; + int wnt2, wnt2_new; + + int wntext3, wntext3_new; + int frizzled3, frizzled3_new; + int dsh3, dsh3_new; + int axin3, axin3_new; + int bcat3, bcat3_new; + int gt1_3, gt1_3_new; + int gt2_3, gt2_3_new; + int delta3, delta3_new; + int deltaext3, deltaext3_new; + int notchic3, notchic3_new; + int p21_3, p21_3_new; + int wnt3, wnt3_new; + + int wntext4, wntext4_new; + int frizzled4, frizzled4_new; + int dsh4, dsh4_new; + int axin4, axin4_new; + int bcat4, bcat4_new; + int gt1_4, gt1_4_new; + int gt2_4, gt2_4_new; + int delta4, delta4_new; + int deltaext4, deltaext4_new; + int notchic4, notchic4_new; + int p21_4, p21_4_new; + int wnt4, wnt4_new; + + // Initialization +/* INIT_WNTEXT(wntext0) ; */ + INIT_VAR(wntext0) ; + INIT_VAR(frizzled0) ; + INIT_VAR(dsh0) ; + INIT_VAR(axin0) ; +/* INIT_VAR(bcat0) ; */ +/* INIT_VAR(gt1_0) ; */ +/* INIT_VAR(gt2_0) ; */ +/* INIT_VAR(delta0) ; */ +/* INIT_VAR(deltaext0) ; */ +/* INIT_VAR(notchic0) ; */ +/* INIT_VAR(p21_0) ; */ +/* INIT_VAR(wnt0) ; */ +/* INIT_VAR(wntext1) ; */ +/* INIT_VAR(frizzled1) ; */ +/* INIT_VAR(dsh1) ; */ +/* INIT_VAR(axin1) ; */ +/* INIT_VAR(bcat1) ; */ +/* INIT_VAR(gt1_1) ; */ +/* INIT_VAR(gt2_1) ; */ +/* INIT_VAR(delta1) ; */ +/* INIT_VAR(deltaext1) ; */ +/* INIT_VAR(notchic1) ; */ +/* INIT_VAR(p21_1) ; */ +/* INIT_VAR(wnt1) ; */ +/* INIT_VAR(wntext2) ; */ +/* INIT_VAR(frizzled2) ; */ +/* INIT_VAR(dsh2) ; */ +/* INIT_VAR(axin2) ; */ +/* INIT_VAR(bcat2) ; */ +/* INIT_VAR(gt1_2) ; */ +/* INIT_VAR(gt2_2) ; */ +/* INIT_VAR(delta2) ; */ +/* INIT_VAR(deltaext2) ; */ +/* INIT_VAR(notchic2) ; */ +/* INIT_VAR(p21_2) ; */ +/* INIT_VAR(wnt2) ; */ +/* INIT_VAR(wntext3) ; */ +/* INIT_VAR(frizzled3) ; */ +/* INIT_VAR(dsh3) ; */ +/* INIT_VAR(axin3) ; */ +/* INIT_VAR(bcat3) ; */ +/* INIT_VAR(gt1_3) ; */ +/* INIT_VAR(gt2_3) ; */ +/* INIT_VAR(delta3) ; */ +/* INIT_VAR(deltaext3) ; */ +/* INIT_VAR(notchic3) ; */ +/* INIT_VAR(p21_3) ; */ +/* INIT_VAR(wnt3) ; */ +/* INIT_VAR(wntext4) ; */ +/* INIT_VAR(frizzled4) ; */ +/* INIT_VAR(dsh4) ; */ +/* INIT_VAR(axin4) ; */ +/* INIT_VAR(bcat4) ; */ +/* INIT_VAR(gt1_4) ; */ +/* INIT_VAR(gt2_4) ; */ +/* INIT_VAR(delta4) ; */ +/* INIT_VAR(deltaext4) ; */ +/* INIT_VAR(notchic4) ; */ +/* INIT_VAR(p21_4) ; */ +/* INIT_VAR(wnt4) ; */ + + return 0; +} diff --git a/test/other/small_ites8.c b/test/other/small_ites8.c new file mode 100644 index 0000000..ccfd7e0 --- /dev/null +++ b/test/other/small_ites8.c @@ -0,0 +1,148 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Many small ite-s. (Taken from SLAyer/test/T2/Skin.c.) + Really hits SLAyer perf. +*/ + +// Initialization macros +#define GRANULARITY 3 + +#define INIT_VAR(V) \ + if (V > GRANULARITY) { V = GRANULARITY; } \ + else if (V < 0) { V = 0; } + + +int main() { + + // Variables. + int wntext0, wntext0_new; + int frizzled0, frizzled0_new; + int dsh0, dsh0_new; + int axin0, axin0_new; + int bcat0, bcat0_new; + int gt1_0, gt1_0_new; + int gt2_0, gt2_0_new; + int delta0, delta0_new; + int deltaext0, deltaext0_new; + int notchic0, notchic0_new; + int p21_0, p21_0_new; + int wnt0, wnt0_new; + + int wntext1, wntext1_new; + int frizzled1, frizzled1_new; + int dsh1, dsh1_new; + int axin1, axin1_new; + int bcat1, bcat1_new; + int gt1_1, gt1_1_new; + int gt2_1, gt2_1_new; + int delta1, delta1_new; + int deltaext1, deltaext1_new; + int notchic1, notchic1_new; + int p21_1, p21_1_new; + int wnt1, wnt1_new; + + int wntext2, wntext2_new; + int frizzled2, frizzled2_new; + int dsh2, dsh2_new; + int axin2, axin2_new; + int bcat2, bcat2_new; + int gt1_2, gt1_2_new; + int gt2_2, gt2_2_new; + int delta2, delta2_new; + int deltaext2, deltaext2_new; + int notchic2, notchic2_new; + int p21_2, p21_2_new; + int wnt2, wnt2_new; + + int wntext3, wntext3_new; + int frizzled3, frizzled3_new; + int dsh3, dsh3_new; + int axin3, axin3_new; + int bcat3, bcat3_new; + int gt1_3, gt1_3_new; + int gt2_3, gt2_3_new; + int delta3, delta3_new; + int deltaext3, deltaext3_new; + int notchic3, notchic3_new; + int p21_3, p21_3_new; + int wnt3, wnt3_new; + + int wntext4, wntext4_new; + int frizzled4, frizzled4_new; + int dsh4, dsh4_new; + int axin4, axin4_new; + int bcat4, bcat4_new; + int gt1_4, gt1_4_new; + int gt2_4, gt2_4_new; + int delta4, delta4_new; + int deltaext4, deltaext4_new; + int notchic4, notchic4_new; + int p21_4, p21_4_new; + int wnt4, wnt4_new; + + // Initialization +/* INIT_WNTEXT(wntext0) ; */ + INIT_VAR(wntext0) ; + INIT_VAR(frizzled0) ; + INIT_VAR(dsh0) ; + INIT_VAR(axin0) ; + INIT_VAR(bcat0) ; + INIT_VAR(gt1_0) ; + INIT_VAR(gt2_0) ; + INIT_VAR(delta0) ; +/* INIT_VAR(deltaext0) ; */ +/* INIT_VAR(notchic0) ; */ +/* INIT_VAR(p21_0) ; */ +/* INIT_VAR(wnt0) ; */ +/* INIT_VAR(wntext1) ; */ +/* INIT_VAR(frizzled1) ; */ +/* INIT_VAR(dsh1) ; */ +/* INIT_VAR(axin1) ; */ +/* INIT_VAR(bcat1) ; */ +/* INIT_VAR(gt1_1) ; */ +/* INIT_VAR(gt2_1) ; */ +/* INIT_VAR(delta1) ; */ +/* INIT_VAR(deltaext1) ; */ +/* INIT_VAR(notchic1) ; */ +/* INIT_VAR(p21_1) ; */ +/* INIT_VAR(wnt1) ; */ +/* INIT_VAR(wntext2) ; */ +/* INIT_VAR(frizzled2) ; */ +/* INIT_VAR(dsh2) ; */ +/* INIT_VAR(axin2) ; */ +/* INIT_VAR(bcat2) ; */ +/* INIT_VAR(gt1_2) ; */ +/* INIT_VAR(gt2_2) ; */ +/* INIT_VAR(delta2) ; */ +/* INIT_VAR(deltaext2) ; */ +/* INIT_VAR(notchic2) ; */ +/* INIT_VAR(p21_2) ; */ +/* INIT_VAR(wnt2) ; */ +/* INIT_VAR(wntext3) ; */ +/* INIT_VAR(frizzled3) ; */ +/* INIT_VAR(dsh3) ; */ +/* INIT_VAR(axin3) ; */ +/* INIT_VAR(bcat3) ; */ +/* INIT_VAR(gt1_3) ; */ +/* INIT_VAR(gt2_3) ; */ +/* INIT_VAR(delta3) ; */ +/* INIT_VAR(deltaext3) ; */ +/* INIT_VAR(notchic3) ; */ +/* INIT_VAR(p21_3) ; */ +/* INIT_VAR(wnt3) ; */ +/* INIT_VAR(wntext4) ; */ +/* INIT_VAR(frizzled4) ; */ +/* INIT_VAR(dsh4) ; */ +/* INIT_VAR(axin4) ; */ +/* INIT_VAR(bcat4) ; */ +/* INIT_VAR(gt1_4) ; */ +/* INIT_VAR(gt2_4) ; */ +/* INIT_VAR(delta4) ; */ +/* INIT_VAR(deltaext4) ; */ +/* INIT_VAR(notchic4) ; */ +/* INIT_VAR(p21_4) ; */ +/* INIT_VAR(wnt4) ; */ + + return 0; +} diff --git a/test/other/store_to_0x0.c b/test/other/store_to_0x0.c new file mode 100644 index 0000000..55852d9 --- /dev/null +++ b/test/other/store_to_0x0.c @@ -0,0 +1,11 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Frontend elides stores to a constant address. +*/ + +int main() { + int x; + x = *(int*)0; // x = [0], but fe translates to x=0; + *(int*)0 = x; // [0] = x , but fe elides completely. +} diff --git a/test/other/store_to_0x0_fix.c b/test/other/store_to_0x0_fix.c new file mode 100644 index 0000000..a92d9c2 --- /dev/null +++ b/test/other/store_to_0x0_fix.c @@ -0,0 +1,11 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Frontend elides stores to a constant address. Fix. +*/ + +#include "slayer.h" + +int main() { + FAIL; +} diff --git a/test/other/straightline.c b/test/other/straightline.c new file mode 100644 index 0000000..5d86330 --- /dev/null +++ b/test/other/straightline.c @@ -0,0 +1,8 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +void main() { + int x, y; + x = 0; + y = x; + return; +} diff --git a/test/other/struct.c b/test/other/struct.c new file mode 100644 index 0000000..b17525c --- /dev/null +++ b/test/other/struct.c @@ -0,0 +1,16 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _cell { + int car; + struct _cell* cdr; +} cell; + +void main() { + cell* x = (cell*)malloc(sizeof(cell)); + cell y; + (*x).car = 1; + y.car = 2; + return; +} diff --git a/test/other/struct_all.c b/test/other/struct_all.c new file mode 100644 index 0000000..1d9044f --- /dev/null +++ b/test/other/struct_all.c @@ -0,0 +1,33 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _cell { + int car; + struct _cell* cdr; +} cell; + +int main() { + int y, *z; + cell v, *x, *w, **u; + y = 3; + z = (int*)malloc(sizeof(int)); + *z = 5; + y = *z; + free(z); + z = &y; + *z = 0; + if(y!=*z) FAIL; + v.car = 53; + v.cdr = 0; + z = &v.car; + x = (cell*)malloc(sizeof(cell)); + (*x).car = 42; + (*x).cdr = 0; + y = (*x).car; + w = (*x).cdr; + z = &(*x).car; + u = &(*x).cdr; + free(x); + free(malloc(sizeof(int))); +} diff --git a/test/other/struct_argument.c b/test/other/struct_argument.c new file mode 100644 index 0000000..29f718b --- /dev/null +++ b/test/other/struct_argument.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _PA { + int i; +} PHYSICAL_ADDRESS; + +typedef struct _S { + struct { + PHYSICAL_ADDRESS f; + } t; +} S, *PS; + +func(PHYSICAL_ADDRESS p) { + p.i = 10; +} + +func2(S s) { + s.t.f.i = 10; +} + +main() { + S s; + PS d; + d = (PS)malloc(sizeof(S)); + func(d->t.f); + s = *d; + func2(s); +} diff --git a/test/other/struct_argument_cl_fail.c b/test/other/struct_argument_cl_fail.c new file mode 100644 index 0000000..b8abd7b --- /dev/null +++ b/test/other/struct_argument_cl_fail.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _PA { + int i; +} PHYSICAL_ADDRESS; + +typedef struct { + struct { + PHYSICAL_ADDRESS f; + } t; +} S, *PS; + +func(PHYSICAL_ADDRESS p) { + p.i = 10; +} + +func2(S s) { + s.t.f.i = 10; +} + +main() { + PS d; + d = (PS)malloc(sizeof(S)); + func(d->t.f); + func2((S)*d); +} diff --git a/test/other/struct_argument_esp_fail.c b/test/other/struct_argument_esp_fail.c new file mode 100644 index 0000000..4e3f94d --- /dev/null +++ b/test/other/struct_argument_esp_fail.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _PA { + int i; +} PHYSICAL_ADDRESS; + +typedef struct { + struct { + PHYSICAL_ADDRESS f; + } t; +} S, *PS; + +func(PHYSICAL_ADDRESS p) { + p.i = 10; +} + +func2(S s) { + s.t.f.i = 10; +} + +main() { + PS d; + d = (PS)malloc(sizeof(S)); + func(d->t.f); + func2(*d); +} diff --git a/test/other/struct_array_copy.c b/test/other/struct_array_copy.c new file mode 100644 index 0000000..86cc0a9 --- /dev/null +++ b/test/other/struct_array_copy.c @@ -0,0 +1,12 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _S { + int x; + int arr[30]; +} S, *PS; + +void +main() { + S s; + s = s; +} diff --git a/test/other/struct_assign_1.c b/test/other/struct_assign_1.c new file mode 100644 index 0000000..f899873 --- /dev/null +++ b/test/other/struct_assign_1.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _cell { + int car; +} cell; + +/* + Check that copy assignment is implemented when assigning a + local struct into another local struct. + */ +int main() { + cell v, x; + + v.car = 5; + + x = v; + + v.car = 6; + + assert(x.car==5); + +} diff --git a/test/other/struct_assign_2.c b/test/other/struct_assign_2.c new file mode 100644 index 0000000..0562b62 --- /dev/null +++ b/test/other/struct_assign_2.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _cell { + int car; +} cell; + +/* + Check that copy assignment is implemented when assigning a + local struct into an allocated struct. + */ +int main() { + cell v, *x; + x = malloc(sizeof(cell)); + + v.car = 5; + + *x = v; + + v.car = 6; + + assert(x->car==5); + + free(x); +} diff --git a/test/other/struct_assign_3.c b/test/other/struct_assign_3.c new file mode 100644 index 0000000..3ba70b6 --- /dev/null +++ b/test/other/struct_assign_3.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _cell { + int car; +} cell; + +/* + Check that copy assignment is implemented when assigning an + allocated struct into a local struct. + */ +int main() { + cell v, *x; + x = malloc(sizeof(cell)); + + x->car = 5; + + v = *x; + + x->car = 6; + + assert(v.car==5); + + free(x); +} diff --git a/test/other/struct_assign_4.c b/test/other/struct_assign_4.c new file mode 100644 index 0000000..fa3b9bb --- /dev/null +++ b/test/other/struct_assign_4.c @@ -0,0 +1,25 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _cell { + int car; +} cell; + +/* + Check that copy assignment is implemented when assigning an + allocated struct into a local struct. + */ +int main() { + cell v, x, y; + + x.car = 5; + + y = v = x; + + x.car = 6; + + assert(y.car==5); + + +} diff --git a/test/other/struct_assign_5.c b/test/other/struct_assign_5.c new file mode 100644 index 0000000..acf72f5 --- /dev/null +++ b/test/other/struct_assign_5.c @@ -0,0 +1,29 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +typedef struct _inner_cell { + int car; +} inner_cell; + +typedef struct _cell { + inner_cell car; +} cell; + +/* + Check that copy assignment is implemented when assigning an + allocated struct into a local struct. + */ +int main() { + cell v, x; + + x.car.car = 5; + + v = x; + + x.car.car = 6; + + assert(v.car.car==5); + + +} diff --git a/test/other/struct_field.c b/test/other/struct_field.c new file mode 100644 index 0000000..ff8b5ea --- /dev/null +++ b/test/other/struct_field.c @@ -0,0 +1,21 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Assign into struct fields. +*/ + +#include "slayer.h" + +typedef struct _val { + void * foo; +} val ; + +int main () +{ + val * y = (val *)malloc(sizeof(val)); + val * z = (val *)malloc(sizeof(val)); + int x; + y->foo = &x; + z->foo = y->foo; + FAIL_IF(&x != z->foo); +} diff --git a/test/other/struct_init.c b/test/other/struct_init.c new file mode 100644 index 0000000..fecedb9 --- /dev/null +++ b/test/other/struct_init.c @@ -0,0 +1,30 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Declare and initialize a struct. +*/ + +#include "slayer.h" + +int a, b; + +struct pair +{ + void* fst; + void* snd; +}; + +// XX initialization +struct pair XX = {&a, &b}; + +void main() +{ + // xx initialization + struct pair xx = {&b, &a}; + + if (! ((XX.fst == &a) && (XX.snd == &b))) { FAIL; } + + if (! ((xx.fst == &b) && (xx.snd == &a))) { FAIL; } + +} + diff --git a/test/other/struct_local.c b/test/other/struct_local.c new file mode 100644 index 0000000..fac77d7 --- /dev/null +++ b/test/other/struct_local.c @@ -0,0 +1,11 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _S { + int f; +} S; + + +main() { + S s; + +} diff --git a/test/other/struct_pass.c b/test/other/struct_pass.c new file mode 100644 index 0000000..a2af0f7 --- /dev/null +++ b/test/other/struct_pass.c @@ -0,0 +1,17 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +typedef struct _S { + int a; + int b; +} S; + +void f(S x) { + x.b = 1; +} + +main() { + S s; + s.b = 0; + f(s); + assert(s.b == 0); +} diff --git a/test/other/switch.c b/test/other/switch.c new file mode 100644 index 0000000..50f4254 --- /dev/null +++ b/test/other/switch.c @@ -0,0 +1,30 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + +*/ +#include "slayer.h" + +void main() +{ + int y = 0; + int x; + switch (x) { + case 0: + y = y + 0; + break; + case 1: + y = y + 1; + break; + case 2: + y = y + 2; + // fall-through + default: + y = y * 10; + break; + } + + assert( x == 0 ? y == 0 : + x == 1 ? y == 1 : + x == 2 ? y == 20 : y == 0 ); + +} diff --git a/test/other/track_global_frees.c b/test/other/track_global_frees.c new file mode 100644 index 0000000..13eee0a --- /dev/null +++ b/test/other/track_global_frees.c @@ -0,0 +1,36 @@ + +#define TRUE (1==1) +#define FALSE (1==0) + +int *p; +int *q; +int freed_p = FALSE; +int freed_q = FALSE; + +void delete(int* obj) +{ + if (obj == p) { freed_p = TRUE; } + if (obj == q) { freed_q = TRUE; } + free(obj); +} + +void main() +{ + int x ; + + p = malloc(sizeof(int)); + *p = 2; + + q = malloc(sizeof(int)); + *q = 2; + + if (x) { + delete(p); + } else { + delete(q); + } + + if (freed_p == FALSE) { free(p); } + if (freed_q == FALSE) { free(q); } + +} diff --git a/test/other/two_elt_array_fptr.c b/test/other/two_elt_array_fptr.c new file mode 100644 index 0000000..a3d6876 --- /dev/null +++ b/test/other/two_elt_array_fptr.c @@ -0,0 +1,44 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + A table of function pointers. + + slam seems to do a sound abstraction for this program: PA tells it that + fun_tbl[] = {f,g}, so whenever fun_tbl[_]() is called, a non-det choice is + made between f() and g(). +*/ + +#include + +int f (int x) +{ + return x+1; +} + +int g (int x) +{ + return x+10; +} + +// pointer to a int->int function. +typedef int (*FP) (int); + + +void main() +{ + int x, y; + FP fun_tbl[2]; + + fun_tbl[0] = f; + fun_tbl[1] = g; + + x = 0; + y = fun_tbl[0](x); + if (y == 0) FAIL; + + x = 0; + y = fun_tbl[1](x); + if (y == 0) FAIL; + + return; +} diff --git a/test/other/two_elt_array_global.c b/test/other/two_elt_array_global.c new file mode 100644 index 0000000..c6af921 --- /dev/null +++ b/test/other/two_elt_array_global.c @@ -0,0 +1,15 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + A is heapified because it's a global. +*/ + +#include "slayer.h" + +int A[2]; + +main () +{ + A[0] = 0; + 1[A] = 1; +} diff --git a/test/other/two_elt_array_local.c b/test/other/two_elt_array_local.c new file mode 100644 index 0000000..ba201d3 --- /dev/null +++ b/test/other/two_elt_array_local.c @@ -0,0 +1,11 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "slayer.h" + +main () +{ + int A[2]; + + A[0] = 0; + 1[A] = 1; +} diff --git a/test/other/unused_global.c b/test/other/unused_global.c new file mode 100644 index 0000000..ed75032 --- /dev/null +++ b/test/other/unused_global.c @@ -0,0 +1,40 @@ +/******************************************************************** + * Copyright (c) Microsoft Corporation. All rights reserved. + +This test highlights a bug in the Ounused optimisation: structs that +are declared globally are optimised away, even if they are used in the +main program. + +Due to this bug, running + slayer -Ounused true *.c -- -no-builtins +results in UNSAFE, whereas running + slayer -Ounused false *.c -- -no-builtins +results in SAFE. This is the correct result, and in any case, an +optimisation shouldn't change the results anyway. + + ******************************************************************/ +#include "slayer_intrinsics.h" + +typedef struct _T { + int x ; + char *y; +} T, *PT; + +T foo = {1, "foo"}; +PT pf = &foo; +T bar = {1, "bar"}; +PT pb = &bar; + + +int main() +{ + // Taking the address locally is OK. +/* PT pfl = &foo; */ +/* PT pbl = &bar; */ +// if (pfl == pbl) { + // But not globally. + if (pf == pb) { + _SLAyer_error(); // Should never get here + } + return 0; +} diff --git a/test/other/unused_global_2.c b/test/other/unused_global_2.c new file mode 100644 index 0000000..7536c1f --- /dev/null +++ b/test/other/unused_global_2.c @@ -0,0 +1,35 @@ +/******************************************************************** + * Copyright (c) Microsoft Corporation. All rights reserved. + +This test highlights a bug in the Ounused optimisation: structs that +are declared globally are optimised away, even if they are used in the +main program. + + ******************************************************************/ +#include "slayer_intrinsics.h" + +typedef struct _T { + int x ; + char *y; +} T, *PT, **PPT; + +T foo = {1, "foo"}; +PT pf = &foo; +T bar = {1, "bar"}; +PT pb = &bar; +T foobar = {1, "foobar"}; //Removed by Ounused analysis (Correct) +PT pb2 = &bar; //Not removed by current Ounused analysis (Sound, but not optimal) +PPT ppb = &pb2; //Not removed by current Ounused analysis (Correct) + +int main() +{ + // Taking the address locally is OK. +/* PT pfl = &foo; */ +/* PT pbl = &bar; */ +// if (pfl == pbl) { + // But not globally. + if (pf == pb) { + _SLAyer_error(); // Should never get here + } + return 0; +} diff --git a/test/other/update_global_var.c b/test/other/update_global_var.c new file mode 100644 index 0000000..a2139b9 --- /dev/null +++ b/test/other/update_global_var.c @@ -0,0 +1,45 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + Update global var in various ways. + A testcase for PS#211, where x=nondet() was being translated as Mov(x,*), + rather than Store(x,*). + This program should be SAFE. +*/ + +#include + +int f(int x) +{ + return x; +} + + +int f_cantinline_me(int x) +{ + int i, y = 0; + for (y=0; y<5; y++) { i++; } + return x; + +} + +int x ; + +void main() { + int y ; + + x = 0; + assert(x == 0); + + x = f(0); + assert(x == 0); + + x = f_cantinline_me(0); + assert(x == 0); + + x = nondet(); + y = x ; + assert(x == y); + + return; +} diff --git a/test/other/while.c b/test/other/while.c new file mode 100644 index 0000000..304e3da --- /dev/null +++ b/test/other/while.c @@ -0,0 +1,8 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +void main() { + int x, y; + y = 0; + while(x!=y) { x = 0; } + return; +} diff --git a/test/other/while2loads.c b/test/other/while2loads.c new file mode 100644 index 0000000..fc7140c --- /dev/null +++ b/test/other/while2loads.c @@ -0,0 +1,22 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + A while loop whose test loads from two memory locations. +*/ + +#include "slayer.h" + +void main() +{ + + int *p; + int *q; + p = (int*) malloc(sizeof(int)); + q = (int*) malloc(sizeof(int)); + *p = 10; + *q = 0; + + while (*p != *q) (*q)++; + + if (*p != *q) FAIL; +} diff --git a/test/other/write_to_busInfo_struct.c b/test/other/write_to_busInfo_struct.c new file mode 100644 index 0000000..08375e7 --- /dev/null +++ b/test/other/write_to_busInfo_struct.c @@ -0,0 +1,65 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + More complicated version of copy_struct_on_stack.c. +*/ +#include "slayer.h" + +typedef struct _GUID { + unsigned long Data1; + unsigned short Data2; + unsigned short Data3; + unsigned char Data4[ 8 ]; +} GUID; +#define DEFINE_GUID(name, l, w1, w2, b1, b2, b3, b4, b5, b6, b7, b8) \ + /*EXTERN_C*/ const GUID /*DECLSPEC_SELECTANY*/ name \ + = { l, w1, w2, { b1, b2, b3, b4, b5, b6, b7, b8 } } + +typedef enum _INTERFACE_TYPE { + InterfaceTypeUndefined = -1, + Internal, + Isa, + Eisa, + MicroChannel, + TurboChannel, + PCIBus, + VMEBus, + NuBus, + PCMCIABus, + CBus, + MPIBus, + MPSABus, + ProcessorInternal, + InternalPowerBus, + PNPISABus, + PNPBus, + Vmcs, + ACPIBus, + MaximumInterfaceType +}INTERFACE_TYPE, *PINTERFACE_TYPE; + +#define ULONG unsigned long + +typedef struct _PNP_BUS_INFORMATION { + GUID BusTypeGuid; + INTERFACE_TYPE LegacyBusType; + ULONG BusNumber; +} PNP_BUS_INFORMATION, *PPNP_BUS_INFORMATION; + + + + + +void main () +{ + PNP_BUS_INFORMATION busInfo; + DEFINE_GUID (GUID_DEVCLASS_TOASTER, + 0xB85B7C50, 0x6A01, 0x11d2, 0xB8, 0x41, 0x00, 0xC0, 0x4F, 0xAD, 0x51, 0x71); + + busInfo.BusTypeGuid = GUID_DEVCLASS_TOASTER; + busInfo.LegacyBusType = PNPBus; + busInfo.BusNumber = 0; + +} + + diff --git a/test/other/writer_reader.c b/test/other/writer_reader.c new file mode 100644 index 0000000..43753ac --- /dev/null +++ b/test/other/writer_reader.c @@ -0,0 +1,45 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + + +-------+ + writer ---> |mailbox| ---> reader + +-------+ + + writer tells reader of mailbox via channel. + + mailbox should be in writer's local-heap. + It should also be in reader's local-heap: if we take account of expr equality when + calculating reachability. + + This program should be SAFE: reader should not have mailbox framed-away. +*/ + +int mailbox; +int lock = 0; + +void writer(int** channel) +{ + lock = 1; + mailbox = 1; + *channel = &mailbox; + lock = 0; +} + +// mailbox \in footprint. +void reader(int* channel) +{ + int x; + lock = 1; + x = *channel; + lock = 0; +} + +void main() +{ + int* channel; + + writer(&channel); + // assert ( (channel == &mailbox) && (mailbox == 1) ) + reader(channel); +} diff --git a/test/scripts/compare_results.gp b/test/scripts/compare_results.gp new file mode 100644 index 0000000..e23e2c8 --- /dev/null +++ b/test/scripts/compare_results.gp @@ -0,0 +1,37 @@ +# columns of data are tab-separated +set datafile separator " " + +# stats doesn't work with logscale +unset logscale +# compute STATS_max for use below +stats "RESULT.compare.tsv" using "Time1" nooutput + +set logscale xy 10 +set xtics 0.1 +set ytics 0.1 +set size square +set key left top Left + +plot [1:STATS_max][1:STATS_max] \ + x/0.001 title "y = 1000x" with lines lt 6, \ + x/0.01 title "y = 100x" with lines lt 7, \ + x/0.1 title "y = 10x" with lines lt 8, \ + x/0.5 title "y = 2x" with lines lt 9, \ + x/(1/1.1) title "y = 1.1x" with lines lt 10, \ + x/1.1 title "1.1y = x" with lines lt 1, \ + x/2 title "2y = x" with lines lt 2, \ + x/10 title "10y = x" with lines lt 3, \ + x/100 title "100y = x" with lines lt 4, \ + x/1000 title "1000y = x" with lines lt 5, \ + "RESULT.compare.tsv" using \ + ((column("Time1")) < 1 ? 1 : (column("Time1"))): \ + ((column("Time2")) < 1 ? 1 : (column("Time2"))) \ + with points pt 2 lc 'black' notitle + + +# # to resize points to have area proportional to the x coordinate: +# "RESULT.merge.tsv" using \ +# ((column("Time1")) < 1 ? 1 : (column("Time1"))): \ +# ((column("Time2")) < 1 ? 1 : (column("Time2"))): \ +# (sqrt(column("Time1"))/sqrt(STATS_max)) \ +# with points pt 2 lc 'black' ps variable notitle diff --git a/test/scripts/compare_results.ml b/test/scripts/compare_results.ml new file mode 100644 index 0000000..b7195a6 --- /dev/null +++ b/test/scripts/compare_results.ml @@ -0,0 +1,98 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + + +type record = { + name: string; + result: string; + total: float; + user: float; + system: float; + memory: float; +} + +let labels = ref [] ;; +let timeout = ref 0 ;; +let pdf = ref false ;; + +Arg.parse [ + ("-timeout", Arg.Set_int timeout, " Time limit (sec)"); + ("-pdf", Arg.Set pdf, " Generate plot as a PDF file"); +] (fun label -> labels := label :: !labels) "" + +let label1, label2 = + match !labels with + | [label2; label1] -> label1, label2 + | _ -> invalid_arg "expected two data file labels" +;; + +let read_file label tbl = + let chan = open_in ("RESULT."^label^".tsv") in + let rec loop () = + try + let mk_record name total user system memory result = {name; total; user; system; memory; result} in + let record = Scanf.fscanf chan "%s %f %f %f %f %[^\n]\n" mk_record in + let record = + if Str.string_match (Str.regexp_string "TIMEOUT") record.result 0 + then {record with total= float_of_int !timeout} + else record in + Hashtbl.add tbl record.name record ; + loop () + with End_of_file -> () + in + loop () ; + close_in chan + +let tbl1 = Hashtbl.create 256 +let tbl2 = Hashtbl.create 256 + +let read_files () = + match !labels with + | [label2; label1] -> + read_file label1 tbl1 ; + read_file label2 tbl2 ; + | _ -> + invalid_arg "must pass two labels determining data files" +;; + +module SS = Set.Make(String) + +let write_merged_results () = + let chan = open_out "RESULT.compare.tsv" + in + let add_names tbl names = + Hashtbl.fold (fun name _ names -> SS.add name names) tbl names + in + let names = add_names tbl1 (add_names tbl2 SS.empty) + in + Printf.fprintf chan "Test\tResult1\tResult2\tTime1\tTime2\n" + ; + SS.iter (fun name -> + try + let {result= result1; total= time1} = Hashtbl.find tbl1 name in + let {result= result2; total= time2} = Hashtbl.find tbl2 name in + Printf.fprintf chan "%s\t%s\t%s\t%f\t%f\n" name result1 result2 time1 time2 + with Not_found -> () + ) names ; + close_out chan +;; + +let generate_plot () = + let gp_commands = + ["set xlabel '"^label1^"'"] @ + ["set ylabel '"^label2^"'"] @ + (if not !pdf then [] else + ["set terminal pdf enhanced font 'Times' size 20cm, 20cm linewidth 1"] @ + ["set output 'RESULT."^label1^"."^label2^".pdf'"] ) + in + let args = [ + "gnuplot" ; + "-p" ; + "-e \""^(String.concat "; " gp_commands)^"\"" ; + "scripts/compare_results.gp" + ] in + ignore( Sys.command (String.concat " " args) ); +;; + +read_files () ; +write_merged_results () ; +generate_plot () ; diff --git a/test/scripts/gather_results.ml b/test/scripts/gather_results.ml new file mode 100644 index 0000000..7f15990 --- /dev/null +++ b/test/scripts/gather_results.ml @@ -0,0 +1,292 @@ +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +let t2 = ref false +let recurse = ref true + +let fnames = ref [] +let test_results = ref [] +let starting_dir = Sys.getcwd () + + +(** Read the results from a file *) +let read_results fname = + if Sys.file_exists fname then begin + let in_ch = open_in fname in + let rec go l = + let (s, has_more) = + try (input_line in_ch, true) with End_of_file -> ("", false) in + if has_more then + let (s1,s2) = + try + let n = String.index s ':' in + let test = String.sub s 0 n in + let result = String.sub s (n+1) (String.length s - n - 1) in + (test, result) + with Not_found -> ("",s) + in + go ((s1,s2)::l) + else + List.fast_sort (fun (x,_) (y,_) -> String.compare x y) l + in + let res = go [] in + close_in in_ch; + res + end else begin + prerr_endline ("Could not find " ^ fname ^ "!"); + [] + end + + +let expected = read_results "EXPECTED.txt" + + +(** One-line summary of results *) +let summarize_res res = + let incr_on_match s t i = if (s=t) then i+1 else i in + let initial_summary = (0,0,0,0,0) in + List.fold_left + (fun (ee,ff,ll,ss,uu) (_,_,_,what,_) -> + let ee' = incr_on_match "error" what ee in + let ff' = incr_on_match "fail" what ff in + let ll' = incr_on_match "limit" what ll in + let ss' = incr_on_match "succ" what ss in + let uu' = if (ee=ee' && ff=ff' && ll=ll' && ss=ss') then (uu+1) else uu in + (ee',ff',ll',ss',uu')) + initial_summary 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 + + +(** Write the results to a txt file *) +let produce_txt fname res = + let ch = open_out fname in + try + let errors, fails, limits, succs, unknowns = summarize_res res in + Printf.fprintf ch "Summary: errors %d, fails %d, limits %d, succs %d, unknowns %d\n" + errors fails limits succs unknowns; + List.iter (fun (name,_what,_time,_mem,msg) -> + Printf.fprintf ch "%s:%s\n" name msg + ) res; + close_out ch + with exn -> + close_out ch; + raise exn + + +(** Write the results to a tsv file *) +let produce_tsv fname res = + with_out fname (fun buf -> + List.iter (fun (name, (utime, stime, ttime), mem, _what, msg) -> + Format.bprintf buf + "%s\t%f\t%f\t%f\t%f\t%s@\n" + name ttime utime stime mem (String.sub msg 0 (min 100 (String.length msg))) + ) res + ) + + +(** Write the results to a html file *) +let produce_html fname res = + (* SI: precompute Summary *) + let errors, fails, limits, succs, unknowns = summarize_res res in + let out_ch = open_out fname in + let pr x = Printf.fprintf out_ch x in + try + pr "Test results\n" ; + pr "" ; + pr "

Test results

\n" ; + + let module U = Unix in + let tm = U.localtime (U.time ()) in + let yy = tm.U.tm_year + 1900 + and mm = tm.U.tm_mon + 1 + and dd = tm.U.tm_mday + and hh = tm.U.tm_hour + and nn = tm.U.tm_min + in + pr "

%d:%02d:%02d:%02d:%02d

\n" + yy mm dd hh nn ; + pr "\ + \ + \n" + errors fails limits succs unknowns ; + pr "
Summary:errors %d, fails %d, limits %d, succs %d, unknowns %d
\ + \ + \ + \ + \ + \n" ; + List.iter (fun (name, (utime, stime, ttime), mem, what, msg) -> + let x = Filename.chop_extension name in + pr "\ + \ + " + what name name what x x x ; + pr "\n\ + \n\ + \n\ + \n\ + \n" + what ttime what utime what stime + what mem what (String.sub msg 0 (min 100 (String.length msg))) + ) res ; + pr "
Test total
(sec)		usr
(sec)		sys
(sec)		Memory
(MB)		Result
%s\ + [cfg]\ + [ats]\ + [out]%12.6f%12.6f%12.6f%12.6f%s
\n" ; + pr "\n" ; + close_out out_ch + with exn -> + close_out out_ch ; + raise exn + + +(** Compare results *) +let compare_results res1 res2 = + let no_found (x,time,mem,what,m) = + if what = "error" then (x,time,mem,what,m) + else (x,time,mem,"fail",m ^ " No expected result found.") in + let rec go res res1 res2 = + match res1, res2 with + | [], _ -> List.rev res + | x::res1, [] -> go (no_found x :: res) res1 [] + | (x,time,mem,what,m)::res1', (x2,m2)::res2' -> + let n = String.compare x x2 in + if n < 0 then + go (no_found (x,time,mem,what,m) :: res) res1' res2 + else if n = 0 then + let res' = + if m = m2 then + (x, time, mem, "succ", m) :: res + else if what = "error" || what = "limit" then + (x, time, mem, what, m^" Expected:"^m2) :: res + else + (x, time, mem, "fail", m^" Expected:"^m2) :: res + in + go res' res1' res2' + else + go res res1 res2' + in + go [] res1 res2 + + +let grep num_groups rex fname = + let inch = open_in fname in + let rec go l = + let s, has_more = + try (input_line inch, true) with End_of_file -> ("", false) in + let l = + try + let _ = Str.search_forward rex s 0 in + let rec loop i z = + if i > num_groups then z else loop (i+1) (Str.matched_group i s :: z) + in + (List.rev (loop 1 [])) :: l + with Not_found -> l in + (if has_more then go l else l) + in + let res = go [] in + close_in inch; + res + +(* Parse a t2 output file *) +let t2_test_file test_t2 = + let test = Filename.chop_extension test_t2 in + let test_c = test ^ ".c" in + let test_out = test ^ ".t2.out" in + + if Sys.file_exists test_out then + let t_rex = Str.regexp "T2 time: \\([0-9.]+\\)s" + in + let t = + match grep 1 t_rex test_out with + | [[t]] -> + let t = float_of_string t in (t, 0., t) + | _ -> + (0.,0.,0.) + in + let mem = 0. in + let res_rex = Str.regexp "RESULT:\\(.*\\)$" in + let r1, r2 = + (match grep 1 res_rex test_out with + | [[" Error: TIMEOUT"]] -> ("error", "TIMEOUT") + | [[" Error: MEMOUT"]] -> ("error", "MEMOUT") + | [s] :: _ -> + let rex = Str.regexp "[^:]*Error:" in + (try ignore (Str.search_forward rex s 0); ("error", s) + with Not_found -> ("succ", s)) + | [] -> ("error", "Error: No result") + | ([] | _::_) :: _ -> assert false (* grep 1 returns lists of singletons *) + ) + in + test_results := (test_c, t, mem, r1, r2) :: !test_results + +(** Parse a slayer output file *) +let test_file test_li = + let test = Filename.chop_extension test_li in + let test_c = test ^ ".c" in + let test_out = test ^ ".slayer.out" in + + if Sys.file_exists test_out then + + let t_rex = Str.regexp "Time: total *\\([0-9.]+\\) *( *\\([0-9.]+\\)) sec" + in + let t = + match grep 2 t_rex test_out with + | [[t;s]] -> + let t = float_of_string t and s = float_of_string s in + (t -. s, s, t) + | _ -> + (0.,0.,0.) + in + let mem_rex = Str.regexp "Memory: total *\\([0-9.]+\\) MB" in + let mem = + match grep 1 mem_rex test_out with + | [[s]] -> float_of_string s + | _ -> 0. + in + let res_rex = Str.regexp "RESULT:\\(.*\\)$" in + let r1, r2 = + (match grep 1 res_rex test_out with + | [[" TIMEOUT"]] -> ("limit", " TIMEOUT") + | [[" MEMOUT"]] -> ("limit", " MEMOUT") + | [[" HIT LIMIT"]] -> ("limit", " HIT LIMIT") + | [s] :: _ -> + let rex = Str.regexp "[^:]*Error:" in + (try ignore (Str.search_forward rex s 0); ("error", s) + with Not_found -> ("succ", s)) + | [] -> ("limit", "Error: No result") + | ([] | _::_) :: _ -> assert false (* grep 1 returns lists of singletons *) + ) + in + test_results := (test_c, t, mem, r1, r2) :: !test_results + + +(** Parse arguments *) +let parse_args () = + let usage = "\nUsage: gather_results test1.li test2.li ..." in + Arg.parse [("-t2", Arg.Unit (fun () -> t2 := true), ": work over t2.out files instead of .li")] (fun s -> fnames := s :: !fnames) usage; + List.sort String.compare !fnames + +let () = + let _ = parse_args() in + let handle_file = if !t2 then t2_test_file else test_file in + List.iter handle_file !fnames; + let res = + List.fast_sort (fun (x,_,_,_,_) (y,_,_,_,_) -> String.compare x y) + !test_results in + let res2 = compare_results res expected in + produce_txt "RESULT.curr.txt" res2 ; + produce_tsv "RESULT.curr.tsv" res2 ; + produce_html "RESULT.curr.html" res2 diff --git a/test/scripts/sort_tests.ml b/test/scripts/sort_tests.ml new file mode 100644 index 0000000..ca2409f --- /dev/null +++ b/test/scripts/sort_tests.ml @@ -0,0 +1,63 @@ +#!/usr/bin/env ocaml +(* Copyright (c) Microsoft Corporation. All rights reserved. *) + +#load "str.cma" ;; + +let try_finally f g = + let res = + try + f () + with e -> + g () ; + raise e + in + g () ; + res + +let with_in file reader = + let chan = open_in file in + try_finally + (fun () -> reader chan) + (fun () -> close_in chan) + + +let tsv_file = ref "RESULT.curr.tsv" +let fnames = ref [] +let prev_times = Hashtbl.create 512 + + +let read_tsv () = + with_in !tsv_file (fun chan -> + try + while true do + let name, ttime, result = + Scanf.fscanf chan "%s %f %f %f %f %[^\n]\n" + (fun name ttime _utime _stime _mem result -> (name, ttime, result)) in + let name = (Filename.chop_extension name) ^ ".sil" in + let time = if Str.string_match (Str.regexp_string "TIMEOUT") result 0 then infinity else ttime in + Hashtbl.replace prev_times name time + done + with End_of_file -> + () + ) + + +let cmp x y = + let c = Pervasives.compare (Hashtbl.find prev_times x) (Hashtbl.find prev_times y) in + if c<>0 then c else String.compare x y + + +let () = + Arg.parse + [("-tsv", Arg.String (fun f -> tsv_file := f), " Read previous run-times from ")] + (fun s -> fnames := s :: !fnames) + "sort_tests {file1.sil}+" + ; + List.iter (fun test -> Hashtbl.add prev_times test max_float) !fnames + ; + (try read_tsv () + with _ -> ()) + ; + let sorted_fnames = List.sort cmp !fnames + in + List.iter (fun fname -> print_string (fname ^ " ")) sorted_fnames diff --git a/test/sll/append.c b/test/sll/append.c new file mode 100644 index 0000000..d8a7068 --- /dev/null +++ b/test/sll/append.c @@ -0,0 +1,18 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void append(PSLL_ENTRY* z, PSLL_ENTRY y) { + while(*z != NULL) { + z = &(*z)->Flink; + } + *z = y; +} + +void main() { + PSLL_ENTRY x, y; + x = SLL_create(nondet()); + y = SLL_create(nondet()); + append(&x, y); + SLL_destroy(x); +} diff --git a/test/sll/append_fs.c b/test/sll/append_fs.c new file mode 100644 index 0000000..f48d7fe --- /dev/null +++ b/test/sll/append_fs.c @@ -0,0 +1,25 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void append(PSLL_ENTRY *a, PSLL_ENTRY y) { + PSLL_ENTRY *z = a; + + while(*z != NULL) { + z = &(*z)->Flink; + } + *z = y; +} + +void main() { + PSLL_ENTRY x, x1, x2, x3, y, y1, y2; + x3 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = NULL; + x2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x2->Flink = x3; + x1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x1->Flink = x2; + x = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x->Flink = x1; + y2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y2->Flink = NULL; + y1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y1->Flink = y2; + y = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y->Flink = y1; + append(&x, y); + SLL_destroy(x); +} diff --git a/test/sll/append_ret.c b/test/sll/append_ret.c new file mode 100644 index 0000000..13dc0d6 --- /dev/null +++ b/test/sll/append_ret.c @@ -0,0 +1,27 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY append(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY t, n, r; + if (x != NULL) { + t = x; + n = x->Flink; + while (n != NULL) { + t = n; + n = n->Flink; + } + t->Flink = y; + return x; + } else { + return y; + } +} + +void main() { + PSLL_ENTRY x, y; + x = SLL_create(nondet()); + y = SLL_create(nondet()); + x = append(x, y); + SLL_destroy(x); +} diff --git a/test/sll/append_ret_fs.c b/test/sll/append_ret_fs.c new file mode 100644 index 0000000..c9d4902 --- /dev/null +++ b/test/sll/append_ret_fs.c @@ -0,0 +1,32 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY append(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY t, n, r; + if (x != NULL) { + t = x; + n = x->Flink; + while (n != NULL) { + t = n; + n = n->Flink; + } + t->Flink = y; + return x; + } else { + return y; + } +} + +void main() { + PSLL_ENTRY x, x1, x2, x3, y, y1, y2; + x3 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = NULL; + x2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x2->Flink = x3; + x1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x1->Flink = x2; + x = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x->Flink = x1; + y2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y2->Flink = NULL; + y1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y1->Flink = y2; + y = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); y->Flink = y1; + x = append(x, y); + SLL_destroy(x); +} diff --git a/test/sll/copy.c b/test/sll/copy.c new file mode 100644 index 0000000..27699e8 --- /dev/null +++ b/test/sll/copy.c @@ -0,0 +1,25 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY copy(PSLL_ENTRY x) { + PSLL_ENTRY y; + SLL_ENTRY* * z = &y; + + while(x != NULL) /* listseg(y,*z) * listseg(-,x) * list(x) */ { + *z = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + (*z)->Data = x->Data; + z = &(*z)->Flink; + x = x->Flink; + } + *z = NULL; + return y; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = SLL_create(nondet()); + y = copy(x); + SLL_destroy(x); + SLL_destroy(y); +} diff --git a/test/sll/copy_leak.c b/test/sll/copy_leak.c new file mode 100644 index 0000000..6130a33 --- /dev/null +++ b/test/sll/copy_leak.c @@ -0,0 +1,25 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY copy(PSLL_ENTRY a) { + PSLL_ENTRY y, x = a; + SLL_ENTRY* * z = &y; + + while(x != NULL) /* listseg(y,*z) * listseg(-,x) * list(x) */ { + *z = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + (*z)->Data = x->Data; + z = &(*z)->Flink; + x = x->Flink; + } + *z = NULL; + return y; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = SLL_create(nondet()); + y = copy(x); + SLL_destroy(x); + // SLL_destroy(y); +} diff --git a/test/sll/create.c b/test/sll/create.c new file mode 100644 index 0000000..fc72d3f --- /dev/null +++ b/test/sll/create.c @@ -0,0 +1,14 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create and then leak a singly-linked list. +**/ + +#include "sll.h" + + +void main(void) { + PSLL_ENTRY head; + + head = SLL_create(nondet()); +} diff --git a/test/sll/create_body.c b/test/sll/create_body.c new file mode 100644 index 0000000..2ff9696 --- /dev/null +++ b/test/sll/create_body.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + printf_s("created link\n") ; + + return head; +} + +void main(void) { + PSLL_ENTRY x; + + x = create(1); + + free(x); +} diff --git a/test/sll/create_fs.c b/test/sll/create_fs.c new file mode 100644 index 0000000..bc02c7c --- /dev/null +++ b/test/sll/create_fs.c @@ -0,0 +1,13 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void main() { + PSLL_ENTRY x, x1, x2, x3; + x3 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = NULL; + x2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x2->Flink = x3; + x1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x1->Flink = x2; + x = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x->Flink = x1; + // ls(x,0) holds here. + SLL_destroy(x); +} diff --git a/test/sll/create_fs_via_tmps.c b/test/sll/create_fs_via_tmps.c new file mode 100644 index 0000000..2e05983 --- /dev/null +++ b/test/sll/create_fs_via_tmps.c @@ -0,0 +1,18 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void main() { + PSLL_ENTRY x = NULL; + PSLL_ENTRY tmp1, tmp2, tmp3, tmp4, tmp5; + tmp1 = cons(1, x); + x = tmp1; + tmp2 = cons(2, x); + x = tmp2; + tmp3 = cons(3, x); + x = tmp3; + tmp4 = cons(4, x); + x = tmp4; + // ls(x,0) doesn't hold here. + SLL_destroy(x); +} diff --git a/test/sll/create_kernel.c b/test/sll/create_kernel.c new file mode 100644 index 0000000..48d21fa --- /dev/null +++ b/test/sll/create_kernel.c @@ -0,0 +1,41 @@ +/***************************************************************************** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create and then leak a doubly-linked list. + This is a kernel-style list, in which the payload is adjacent to the links. + + This is a generalization of the harness setup in + kmdf/1394/address_range_plist_entry. + + *****************************************************************************/ + +#include "slayer.h" +#include "../kmdf/harness.h" +#include "../kmdf/1394.h" + +void main() +{ + PDEVICE_EXTENSION deviceExtension; + int* addr_range ; + ASYNC_ADDRESS_DATA *aad ; + int aad_count, i ; + + deviceExtension = (PDEVICE_EXTENSION)malloc(sizeof(DEVICE_EXTENSION)); + InitializeListHead(&(deviceExtension->AsyncAddressData)); + + for (i=0; ipMdl = (PMDL)malloc(sizeof(MDL)); + + aad->Buffer = malloc(1); + + aad->AddressRange = (PADDRESS_RANGE)malloc(sizeof(ADDRESS_RANGE)); + + InsertHeadList(&(deviceExtension->AsyncAddressData), &(aad->AsyncAddressList)); + } + + return ; + +} diff --git a/test/sll/create_seg.c b/test/sll/create_seg.c new file mode 100644 index 0000000..0656de2 --- /dev/null +++ b/test/sll/create_seg.c @@ -0,0 +1,14 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create and then leak a singly-linked list segment. +**/ + +#include "sll.h" + + +void main(void) { + PSLL_ENTRY head, tail; + + head = SLL_create_seg(nondet(), tail); +} diff --git a/test/sll/create_via_tmps.c b/test/sll/create_via_tmps.c new file mode 100644 index 0000000..6c0fb6d --- /dev/null +++ b/test/sll/create_via_tmps.c @@ -0,0 +1,17 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + + +void main(void) { + PSLL_ENTRY x= NULL; + int i, len; + for (i=0; iFlink ) { + free(head); + } else { + SLL_destroy_seg(head, tail->Flink); + } + /* tail->Flink may have been in the list, so this may leak a cycle */ +} diff --git a/test/sll/filter.c b/test/sll/filter.c new file mode 100644 index 0000000..ca5f27b --- /dev/null +++ b/test/sll/filter.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void filter(PSLL_ENTRY *a, int i) { + PSLL_ENTRY t, *z = a; + + while(*z != NULL) + if((*z)->Data == i) { + t = *z; + *z = t->Flink; + free(t); + } else { + z = &(*z)->Flink; + } +} + +void main() { + PSLL_ENTRY x = SLL_create(nondet()); + + print_list(x); printf_s("\n"); + + filter(&x, 1); + + print_list(x); + + SLL_destroy(x); +} diff --git a/test/sll/filter_fs.c b/test/sll/filter_fs.c new file mode 100644 index 0000000..6a47661 --- /dev/null +++ b/test/sll/filter_fs.c @@ -0,0 +1,30 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void filter(PSLL_ENTRY *a, int i) { + PSLL_ENTRY t, *z = a; + + while(*z != NULL) + if((*z)->Data == i) { + t = *z; + *z = t->Flink; + free(t); + } else { + z = &(*z)->Flink; + } +} + +void main() { + PSLL_ENTRY x, x1, x2, x3, x4, x5; + x5 = cons(1, NULL); + x4 = cons(4, x5); + x3 = cons(1, x4); + x2 = cons(3, x3); + x1 = cons(2, x2); + x = cons(1, x1); + print_list(x); printf_s("\n"); + filter(&x, 1); + print_list(x); + SLL_destroy(x); +} diff --git a/test/sll/filter_ret.c b/test/sll/filter_ret.c new file mode 100644 index 0000000..660cb4d --- /dev/null +++ b/test/sll/filter_ret.c @@ -0,0 +1,47 @@ +/* + Copyright (c) Microsoft Corporation. All rights reserved. + + version of filter that does not use sub-object pointers, and hence must + special-case removing the first link and return the filtered list +*/ + +#include "sll.h" + +/* remove all links with Data a from x */ +PSLL_ENTRY filter(PSLL_ENTRY x, int a) { + PSLL_ENTRY y, z; + + y = x; + z = NULL; + while(y != NULL) { + if(y->Data == a) { /* need to remove y */ + if(y == x) { /* first link */ + x = y->Flink; + free(y); + y = x; + } else { /* not first link */ + z->Flink = y->Flink; + free(y); + y = z->Flink; + } + } else { /* don't need to remove y */ + z = y; + y = y->Flink; + } + } + return x; +} + +void main() { + PSLL_ENTRY x = NULL; + x = cons(1, x); + x = cons(4, x); + x = cons(1, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + x = filter(x, 1); + print_list(x); + SLL_destroy(x); +} diff --git a/test/sll/find.c b/test/sll/find.c new file mode 100644 index 0000000..7678ce8 --- /dev/null +++ b/test/sll/find.c @@ -0,0 +1,24 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +// advance to first link of x greater than n +void find(PSLL_ENTRY *a, int n) { + PSLL_ENTRY *z = a; + + while(*z != NULL && (*z)->Data <= n) { + z = &(*z)->Flink; + } + *a = *z; +} + +void main() { + PSLL_ENTRY x = NULL, y; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + y = x; + find(&x, 2); + SLL_destroy(y); +} diff --git a/test/sll/find_ret.c b/test/sll/find_ret.c new file mode 100644 index 0000000..53e75e9 --- /dev/null +++ b/test/sll/find_ret.c @@ -0,0 +1,22 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +// return first link of x greater than n +PSLL_ENTRY find(PSLL_ENTRY x, int n) { + while (x != NULL) { + if (x->Data > n) return x; + x = x->Flink; + } + return NULL; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + y = find(x, 2); + SLL_destroy(x); +} diff --git a/test/sll/heap.h b/test/sll/heap.h new file mode 100644 index 0000000..0fa4c6c --- /dev/null +++ b/test/sll/heap.h @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include + +/* Note: be able to compile under non-SLAyer circumstances. */ +#ifndef SLAyer +#include +#else +int printf (const char *fmt,...) { return 0; } +int printf_s (const char *fmt,...) { return 0; } +#endif + +typedef struct cell { + int car; + struct cell* cdr; +} cell; + +cell* new() { + cell* x = (cell*)malloc(sizeof(cell)); + assert(x != NULL); + return x; +} + +void print_cell(cell* x) { + printf("%i", x->car); +} + + diff --git a/test/sll/insert.c b/test/sll/insert.c new file mode 100644 index 0000000..2ef93b8 --- /dev/null +++ b/test/sll/insert.c @@ -0,0 +1,22 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void insert(PSLL_ENTRY *a, PSLL_ENTRY x) { + PSLL_ENTRY *l = a; + + while(*l != NULL && (*l)->Data < x->Data) { + l = &(*l)->Flink; + } + x->Flink = *l; + *l = x; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(2, x); + x = cons(1, x); + insert(&x, cons(3, y)); + SLL_destroy(x); +} diff --git a/test/sll/insert_ret.c b/test/sll/insert_ret.c new file mode 100644 index 0000000..5115a6d --- /dev/null +++ b/test/sll/insert_ret.c @@ -0,0 +1,32 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY insert(PSLL_ENTRY l, PSLL_ENTRY x) { + PSLL_ENTRY elem, prev; + elem = l; + prev = NULL; + while (elem != NULL) { + if (elem->Data >= x->Data) { + x->Flink = elem; + if (prev == NULL) return x; + prev->Flink = x; + return l; + } + prev = elem; + elem = elem->Flink; + } + x->Flink = elem; + if (prev == NULL) return x; + prev->Flink = x; + return l; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(2, x); + x = cons(1, x); + x = insert(x, cons(3, y)); + SLL_destroy(x); +} diff --git a/test/sll/insertion_sort.c b/test/sll/insertion_sort.c new file mode 100644 index 0000000..0fe5d26 --- /dev/null +++ b/test/sll/insertion_sort.c @@ -0,0 +1,43 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY insert(PSLL_ENTRY l, PSLL_ENTRY x) { + PSLL_ENTRY elem, prev; + elem = l; + prev = NULL; + while (elem != NULL) { + if (elem->Data >= x->Data) { + x->Flink = elem; + if (prev == NULL) return x; + prev->Flink = x; + return l; + } + prev = elem; + elem = elem->Flink; + } + x->Flink = elem; + if (prev == NULL) return x; + prev->Flink = x; + return l; +} + +PSLL_ENTRY insertion_sort(PSLL_ENTRY x) { + PSLL_ENTRY h, ret, cand; + h = x; + ret = NULL; + while (h != NULL) { + cand = h; + h = h->Flink; + cand->Flink = NULL; + ret = insert(ret, cand); + } + return ret; +} + +void main() { + PSLL_ENTRY x; + x = SLL_create(17); + x = insertion_sort(x); + SLL_destroy(x); +} diff --git a/test/sll/insertion_sort_inlined.c b/test/sll/insertion_sort_inlined.c new file mode 100644 index 0000000..efd98d8 --- /dev/null +++ b/test/sll/insertion_sort_inlined.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void main() { + PSLL_ENTRY x = NULL, y, c, h, elem, prev; + x = SLL_create(17); + + c = x; + x = NULL; + while (c != NULL) { + y = c; + c = c->Flink; + y->Flink = NULL; + elem = x; + prev = NULL; + while (elem != NULL) { + if (elem->Data >= y->Data) { + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + goto retn; + } + prev = elem; + elem = elem->Flink; + } + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + retn: ; + } + + SLL_destroy(c); + SLL_destroy(x); +} diff --git a/test/sll/insertion_sort_inlined_leak.c b/test/sll/insertion_sort_inlined_leak.c new file mode 100644 index 0000000..7d114ce --- /dev/null +++ b/test/sll/insertion_sort_inlined_leak.c @@ -0,0 +1,32 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void main() { + PSLL_ENTRY x = NULL, y, c, h, elem, prev; + x = SLL_create(17); + + c = x; + x = NULL; + while (c != NULL) { + y = c; + c = c->Flink; + y->Flink = NULL; + elem = x; + prev = NULL; + while (elem != NULL) { + if (elem->Data >= y->Data) { + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + goto retn; + } + prev = elem; + elem = elem->Flink; + } + y->Flink = elem; + if (prev == NULL) { x = y; goto retn; } + prev->Flink = y; + retn: ; + } +} diff --git a/test/sll/print.c b/test/sll/print.c new file mode 100644 index 0000000..6c6bba6 --- /dev/null +++ b/test/sll/print.c @@ -0,0 +1,8 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ +#include "sll.h" + +void main() { + PSLL_ENTRY x = SLL_create(nondet()); + print_list(x); + SLL_destroy(x); +} diff --git a/test/sll/print_fs.c b/test/sll/print_fs.c new file mode 100644 index 0000000..2bad6e5 --- /dev/null +++ b/test/sll/print_fs.c @@ -0,0 +1,13 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void main() { + PSLL_ENTRY x, x1, x2, x3; + x3 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x3->Flink = NULL; + x2 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x2->Flink = x3; + x1 = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x1->Flink = x2; + x = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); x->Flink = x1; + print_list(x); + SLL_destroy(x); +} diff --git a/test/sll/remove_ret.c b/test/sll/remove_ret.c new file mode 100644 index 0000000..d303f24 --- /dev/null +++ b/test/sll/remove_ret.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY sll_remove(PSLL_ENTRY l, PSLL_ENTRY x) { + PSLL_ENTRY elem, prev, t; + elem = l; + prev = NULL; + while (elem != NULL) { + if (elem == x) { + if (prev == NULL) { + t = elem->Flink; + free(elem); + return t; + } else { + t = elem->Flink; + prev->Flink = t; + free(elem); + } + return l; + } + prev = elem; + elem = elem->Flink; + } + return l; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + y = cons(3, y); + y = cons(2, y); + x = cons(1, y); + x = sll_remove(x, y); + SLL_destroy(x); +} diff --git a/test/sll/reverse.c b/test/sll/reverse.c new file mode 100644 index 0000000..c08cb63 --- /dev/null +++ b/test/sll/reverse.c @@ -0,0 +1,34 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +/* + Reverse the list pointed to by l. + Implemented by poping off each item of *l into r. +*/ +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + c = c->Flink; + t->Flink = r; + r = t; + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_div.c b/test/sll/reverse_div.c new file mode 100644 index 0000000..cb770f8 --- /dev/null +++ b/test/sll/reverse_div.c @@ -0,0 +1,35 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse.c but may nondeterministically do nothing during + reversal, thereby causing divergence. +**/ + +#include "sll.h" + + +void reverse_div(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + if (nondet()) { /* nondeterministically do nothing */ + PSLL_ENTRY t; + t = c; + c = c->Flink; + t->Flink = r; + r = t; + } + } + *l = r; +} + + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse_div(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_div2.c b/test/sll/reverse_div2.c new file mode 100644 index 0000000..9c9f40f --- /dev/null +++ b/test/sll/reverse_div2.c @@ -0,0 +1,40 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse.c but may nondeterministically undo one step of reversal + during reversal, thereby causing divergence. +**/ + +#include "sll.h" + + +void reverse_div(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + c = c->Flink; + t->Flink = r; + r = t; + if (nondet() && c!=NULL) { + t = c; + c = c->Flink; + t->Flink = r; + r = t; + } + } + *l = r; +} + + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse_div(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_div3.c b/test/sll/reverse_div3.c new file mode 100644 index 0000000..9713020 --- /dev/null +++ b/test/sll/reverse_div3.c @@ -0,0 +1,35 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, attempt to reverse, and then destroy a singly-linked list. + + Similar to reverse.c but sometimes breaks the list, gets lost, and + diverges. All executions that break the list must diverge in + reverse, so this program is still safe. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + if (c->Data != 5) + c = c->Flink; + t->Flink = r; + r = t; + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_div4.c b/test/sll/reverse_div4.c new file mode 100644 index 0000000..bb9d178 --- /dev/null +++ b/test/sll/reverse_div4.c @@ -0,0 +1,31 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/** + Create, attempt to reverse, and then leak a singly-linked list. + + Similar to reverse_div3.c but never advances the cursor pointer. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + t->Flink = r; + r = t; + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_div5.c b/test/sll/reverse_div5.c new file mode 100644 index 0000000..15e5bd1 --- /dev/null +++ b/test/sll/reverse_div5.c @@ -0,0 +1,35 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, attempt to reverse, and then destroy a singly-linked list. + + Similar to reverse_div3.c but nondeterministically breaks the list, + so that reverse may terminate with a cyclic list, which destroy + crashes on. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + if (nondet()) + c = c->Flink; + t->Flink = r; + r = t; + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_leak.c b/test/sll/reverse_leak.c new file mode 100644 index 0000000..5a81335 --- /dev/null +++ b/test/sll/reverse_leak.c @@ -0,0 +1,34 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse.c but may leak an item. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + c = c->Flink; + if (t->Data != 1) { /* leak t */ + t->Flink = r; + r = t; + } + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_leak2.c b/test/sll/reverse_leak2.c new file mode 100644 index 0000000..4e08dab --- /dev/null +++ b/test/sll/reverse_leak2.c @@ -0,0 +1,34 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list. + + Similar to reverse_leak.c but chooses leaked item nondeterministically. +**/ + +#include "sll.h" + + +void reverse(PSLL_ENTRY *l) { + PSLL_ENTRY c = *l, r = NULL; + while(c != NULL) { + PSLL_ENTRY t; + t = c; + c = c->Flink; + if (nondet()) { /* leak t */ + t->Flink = r; + r = t; + } + } + *l = r; +} + +void main() { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + + reverse(&head); + + SLL_destroy(head); +} diff --git a/test/sll/reverse_negative_sublists.c b/test/sll/reverse_negative_sublists.c new file mode 100644 index 0000000..4c0353d --- /dev/null +++ b/test/sll/reverse_negative_sublists.c @@ -0,0 +1,70 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void reverse_negative_sublists(PSLL_ENTRY *z) { + PSLL_ENTRY t, x, y, *w; + x = *z; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = &(x->Flink); + x = *z; + } + if(x != NULL) { + y = x; + w = &(x->Flink); + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + *w = x; + *z = y; + z = w; + } + else { + *z = NULL; + } + } +} + +PSLL_ENTRY reverse_negative_sublists2(PSLL_ENTRY x) { + PSLL_ENTRY t, y, w, v, z; + v = cons(0,x); + z = v; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = x; + x = x->Flink; + } + if(x != NULL) { + y = w = x; + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + w->Flink = x; + z->Flink = y; + z = w; + } + else { + z->Flink = NULL; + } + } + t = v->Flink; + free(v); + return t; +} + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + x = reverse_negative_sublists2(x); + reverse_negative_sublists(&x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_negative_sublists1.c b/test/sll/reverse_negative_sublists1.c new file mode 100644 index 0000000..5c70437 --- /dev/null +++ b/test/sll/reverse_negative_sublists1.c @@ -0,0 +1,38 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void reverse_negative_sublists(PSLL_ENTRY *z) { + PSLL_ENTRY t, x, y, *w; + x = *z; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = &(x->Flink); + x = *z; + } + if(x != NULL) { + y = x; + w = &(x->Flink); + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + *w = x; + *z = y; + z = w; + } + else { + *z = NULL; + } + } +} + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + reverse_negative_sublists(&x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_negative_sublists1_leak.c b/test/sll/reverse_negative_sublists1_leak.c new file mode 100644 index 0000000..26c286e --- /dev/null +++ b/test/sll/reverse_negative_sublists1_leak.c @@ -0,0 +1,37 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void reverse_negative_sublists(PSLL_ENTRY *z) { + PSLL_ENTRY t, x, y, *w; + x = *z; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = &(x->Flink); + x = *z; + } + if(x != NULL) { + y = x; + w = &(x->Flink); + while(x != NULL && x->Data < 0) { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + *w = x; + *z = y; + z = w; + } + else { + *z = NULL; + } + } +} + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + reverse_negative_sublists(&x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_negative_sublists1_unsafe.c b/test/sll/reverse_negative_sublists1_unsafe.c new file mode 100644 index 0000000..8204835 --- /dev/null +++ b/test/sll/reverse_negative_sublists1_unsafe.c @@ -0,0 +1,37 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void reverse_negative_sublists(PSLL_ENTRY *z) { + PSLL_ENTRY t, x, y, *w; + x = *z; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = &(x->Flink); + x = *z; + } + if(x != NULL) { + y = x; + w = &(x->Flink); + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + *w = x; + *z = y; + } + else { + *z = NULL; + } + } +} + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + reverse_negative_sublists(&x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_negative_sublists2.c b/test/sll/reverse_negative_sublists2.c new file mode 100644 index 0000000..513dcf6 --- /dev/null +++ b/test/sll/reverse_negative_sublists2.c @@ -0,0 +1,43 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +/* a version that doesn't use pointers into records, call-by-reference, or + conditional assertions */ +PSLL_ENTRY reverse_negative_sublists2(PSLL_ENTRY x) { + PSLL_ENTRY t, y, w, v, z; + v = cons(0,x); + z = v; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = x; + x = x->Flink; + } + if(x != NULL) { + y = w = x; + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + w->Flink = x; + z->Flink = y; + z = w; + } + else { + z->Flink = NULL; + } + } + t = v->Flink; + free(v); + return t; +} + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + x = reverse_negative_sublists2(x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_negative_sublists2_leak.c b/test/sll/reverse_negative_sublists2_leak.c new file mode 100644 index 0000000..d2cef82 --- /dev/null +++ b/test/sll/reverse_negative_sublists2_leak.c @@ -0,0 +1,42 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +/* a version that doesn't use pointers into records, call-by-reference, or + conditional assertions */ +PSLL_ENTRY reverse_negative_sublists2(PSLL_ENTRY x) { + PSLL_ENTRY t, y, w, v, z; + v = cons(0,x); + z = v; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = x; + x = x->Flink; + } + if(x != NULL) { + y = w = x; + while(x != NULL && x->Data < 0) { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + w->Flink = x; + z->Flink = y; + z = w; + } + else { + z->Flink = NULL; + } + } + t = v->Flink; + free(v); + return t; +} + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + x = reverse_negative_sublists2(x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_negative_sublists2_unsafe.c b/test/sll/reverse_negative_sublists2_unsafe.c new file mode 100644 index 0000000..68fe079 --- /dev/null +++ b/test/sll/reverse_negative_sublists2_unsafe.c @@ -0,0 +1,42 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +/* a version that doesn't use pointers into records, call-by-reference, or + conditional assertions */ +PSLL_ENTRY reverse_negative_sublists2(PSLL_ENTRY x) { + PSLL_ENTRY t, y, w, v, z; + v = cons(0,x); + z = v; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = x; + x = x->Flink; + } + if(x != NULL) { + y = w = x; + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + w->Flink = x; + z->Flink = y; + } + else { + z->Flink = NULL; + } + } + t = v->Flink; + free(v); + return t; +} + +void main() { + PSLL_ENTRY x = NULL; + x = SLL_create(nondet()); + x = reverse_negative_sublists2(x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_negative_sublists_fs.c b/test/sll/reverse_negative_sublists_fs.c new file mode 100644 index 0000000..d10c51e --- /dev/null +++ b/test/sll/reverse_negative_sublists_fs.c @@ -0,0 +1,86 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void reverse_negative_sublists(PSLL_ENTRY *z) { + PSLL_ENTRY t, x, y, *w; + x = *z; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = &(x->Flink); + x = *z; + } + if(x != NULL) { + y = x; + w = &(x->Flink); + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + *w = x; + *z = y; + z = w; + } + else { + *z = NULL; + } + } +} + +PSLL_ENTRY reverse_negative_sublists2(PSLL_ENTRY x) { + PSLL_ENTRY t, y, w, v, z; + v = cons(0,x); + z = v; + while(x != NULL) { + while(x != NULL && x->Data >= 0) { + z = x; + x = x->Flink; + } + if(x != NULL) { + y = w = x; + do { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + while(x != NULL && x->Data < 0); + w->Flink = x; + z->Flink = y; + z = w; + } + else { + z->Flink = NULL; + } + } + t = v->Flink; + free(v); + return t; +} + + +void main() { + PSLL_ENTRY x, x0, x1, x2, x3, x4, x5, x6, x7; + x7 = cons(7, NULL); + x6 = cons(-6, x7); + x5 = cons(-5, x6); + x4 = cons(-4, x5); + x3 = cons(0, x4); + x2 = cons(3, x3); + x1 = cons(-2, x2); + x0 = cons(-1, x1); + x = x0; + x = reverse_negative_sublists2(x); + reverse_negative_sublists(&x); + free(x7); + free(x6); + free(x5); + free(x4); + free(x3); + free(x2); + free(x1); + free(x0); +} diff --git a/test/sll/reverse_ret.c b/test/sll/reverse_ret.c new file mode 100644 index 0000000..1834a07 --- /dev/null +++ b/test/sll/reverse_ret.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY reverse(PSLL_ENTRY a) { + PSLL_ENTRY x = a; + PSLL_ENTRY o, t; + o = NULL; + while (x != NULL) { + t = x->Flink; + x->Flink = o; + o = x; + x = t; + } + return o; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + x = reverse(x); + SLL_destroy(x); +} diff --git a/test/sll/reverse_seg.c b/test/sll/reverse_seg.c new file mode 100644 index 0000000..3e1bdd8 --- /dev/null +++ b/test/sll/reverse_seg.c @@ -0,0 +1,33 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then destroy a singly-linked list segment. +**/ + +#include "sll.h" + + +void reverse_seg(PSLL_ENTRY *z, SLL_ENTRY *w) { + PSLL_ENTRY t, x = *z, y = w; + while(x != w) { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + *z = y; +} + +void main() { + int length; + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + + head = SLL_create_seg(length, tail); + + reverse_seg(&head, tail); + + SLL_destroy_seg(head, tail); + free(tail); +} diff --git a/test/sll/reverse_seg_cyclic.c b/test/sll/reverse_seg_cyclic.c new file mode 100644 index 0000000..919ff8b --- /dev/null +++ b/test/sll/reverse_seg_cyclic.c @@ -0,0 +1,30 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, reverse, and then leak a singly-linked list segment. + + Similar to reverse_seg.c but the segment might be cyclic or a lasso. +**/ + +#include "sll.h" + + +void reverse_seg(PSLL_ENTRY *z, SLL_ENTRY *w) { + PSLL_ENTRY t, x = *z, y = w; + while(x != w) { + t = x; + x = x->Flink; + t->Flink = y; + y = t; + } + *z = y; +} + +void main() { + int length; + PSLL_ENTRY head, tail; + + head = SLL_create_seg(length, tail); + + reverse_seg(&head, tail); +} diff --git a/test/sll/sll.h b/test/sll/sll.h new file mode 100644 index 0000000..2127bd7 --- /dev/null +++ b/test/sll/sll.h @@ -0,0 +1,133 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Common definitions for singly-linked lists. +**/ + +#include + +/* In non-SLAyer case, allow tests to be compiled. */ +#ifndef SLAyer +#include +#else +int printf (const char *fmt,...) { return 0; } +#endif + + +typedef struct _SLL_ENTRY { + int Data; + struct _SLL_ENTRY *Flink; +} SLL_ENTRY, *PSLL_ENTRY; + + +/* Construction */ + +PSLL_ENTRY cons(int a, SLL_ENTRY* d) { + PSLL_ENTRY x = (SLL_ENTRY*)malloc(sizeof(SLL_ENTRY)); + x->Data = a; + x->Flink = d; + return x; +} + +PSLL_ENTRY SLL_create_seg(int length, PSLL_ENTRY head) { + int i; + PSLL_ENTRY tmp; + + for(i = 0; i < length; i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +PSLL_ENTRY SLL_create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; i < length; i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +/* +PSLL_ENTRY create(int length) { + return create_seg(length, NULL); +} +*/ + +/* Destruction */ + +void SLL_destroy_seg(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY t; + + while(x != y) { + t = x; + x = x->Flink; + free(t); + } +} + +void SLL_destroy(PSLL_ENTRY x) { + SLL_destroy_seg(x, NULL); +} + +/* +void SLL_destroy(PSLL_ENTRY x) { + PSLL_ENTRY t; + + while(x != NULL) { + t = x; + x = x->Flink; + free(t); + } +} +*/ + + +/* Printing */ + +void print_link(PSLL_ENTRY x) { + printf("%p -> {D:%i, F:%p}", x, x->Data, x->Flink); +/* printf("%i", x->Data); */ +} + +void print_listseg(PSLL_ENTRY a, SLL_ENTRY* y) { + PSLL_ENTRY x = a; + + printf("("); + if(x != y) { + print_link(x); + x = x->Flink; + while(x != y) { + printf(",\n "); + print_link(x); + x = x->Flink; + }; + }; + printf(")\n"); +} + +/* void print_list(PSLL_ENTRY x) { print_listseg(x, 0); } */ + +void print_list(PSLL_ENTRY a) { + PSLL_ENTRY x = a; + + printf("("); + if(x != NULL) { + print_link(x); + x = x->Flink; + while(x != NULL) { + printf(", "); + print_link(x); + x = x->Flink; + }; + }; + printf(")"); +} diff --git a/test/sll/splice.c b/test/sll/splice.c new file mode 100644 index 0000000..7a3e1a7 --- /dev/null +++ b/test/sll/splice.c @@ -0,0 +1,35 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY splice(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY p, q, t; + p = x; + q = y; + if (p == NULL) return q; + if (q == NULL) return p; + while (1) { + t = q; + q = t->Flink; + t->Flink = p->Flink; + p->Flink = t; + if (p == NULL) return x; + p = t->Flink; + if (q == NULL) return x; + if (p == NULL) { + t->Flink = q; + return x; + } + } + if (p == NULL) + t->Flink = q; + return x; +} + +void main() { + PSLL_ENTRY x, y, z; + x = SLL_create(nondet()); + y = SLL_create(nondet()); + z = splice(x, y); + SLL_destroy(z); +} diff --git a/test/sll/splice_fs.c b/test/sll/splice_fs.c new file mode 100644 index 0000000..4fd9227 --- /dev/null +++ b/test/sll/splice_fs.c @@ -0,0 +1,40 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY splice(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY p, q, t; + p = x; + q = y; + if (p == NULL) return q; + if (q == NULL) return p; + while (1) { + t = q; + q = t->Flink; + t->Flink = p->Flink; + p->Flink = t; + if (p == NULL) return x; + p = t->Flink; + if (q == NULL) return x; + if (p == NULL) { + t->Flink = q; + return x; + } + } + if (p == NULL) + t->Flink = q; + return x; +} + +void main() { + PSLL_ENTRY x, x1, x2, y, y1, y2, y3, z; + x2 = cons(3, NULL); + x1 = cons(2, x2); + x = cons(1, x1); + y3 = cons(7, NULL); + y2 = cons(6, y3); + y1 = cons(5, y2); + y = cons(4, y1); + z = splice(x, y); + SLL_destroy(z); +} diff --git a/test/sll/straightline.c b/test/sll/straightline.c new file mode 100644 index 0000000..711a7a7 --- /dev/null +++ b/test/sll/straightline.c @@ -0,0 +1,19 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create and then leak a singly-linked list of fixed length. +**/ + +#include "sll.h" + +void main() { + PSLL_ENTRY x = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); +} diff --git a/test/sll/traverse.c b/test/sll/traverse.c new file mode 100644 index 0000000..c0045a0 --- /dev/null +++ b/test/sll/traverse.c @@ -0,0 +1,22 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); +} diff --git a/test/sll/traverse2.c b/test/sll/traverse2.c new file mode 100644 index 0000000..d737ab4 --- /dev/null +++ b/test/sll/traverse2.c @@ -0,0 +1,27 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. + + Similar to traverse.c but using a pointer to the Flink field itself instead + of to the struct containing Flink. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY *a) { + PSLL_ENTRY *z = a; + + while(*z != NULL) { + z = &(*z)->Flink; + } +} + +void main(void) { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + traverse(&head); + SLL_destroy(head); +} diff --git a/test/sll/traverse3.c b/test/sll/traverse3.c new file mode 100644 index 0000000..d564c6a --- /dev/null +++ b/test/sll/traverse3.c @@ -0,0 +1,30 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. + + Similar to traverse.c but only conditionally performs the creation and + traversal. +**/ + +#include "sll.h" + +void traverse(PSLL_ENTRY head) { + PSLL_ENTRY tmp = head; + + while(tmp != NULL) { + tmp = tmp->Flink ; + } +} + + +void main(void) { + PSLL_ENTRY head; + int length; + + if (length == 1000) { + head = SLL_create(length); + traverse(head); + SLL_destroy(head); + } +} diff --git a/test/sll/traverse4.c b/test/sll/traverse4.c new file mode 100644 index 0000000..b0ff392 --- /dev/null +++ b/test/sll/traverse4.c @@ -0,0 +1,30 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. + + Similar to traverse3.c but the length variable is global. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + PSLL_ENTRY tmp = head; + + while(tmp != NULL) { + tmp = tmp->Flink ; + } +} + +int length; + +void main(void) { + PSLL_ENTRY head; + + if (length == 1000) { + head = SLL_create(length); + traverse(head); + SLL_destroy(head); + } +} diff --git a/test/sll/traverse5.c b/test/sll/traverse5.c new file mode 100644 index 0000000..d56bb75 --- /dev/null +++ b/test/sll/traverse5.c @@ -0,0 +1,26 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. + + Similar to traverse.c but using a temporary variable. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + PSLL_ENTRY tmp = head; + + while(tmp != NULL) { + tmp = tmp->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); +} diff --git a/test/sll/traverse_1lists.c b/test/sll/traverse_1lists.c new file mode 100644 index 0000000..14de803 --- /dev/null +++ b/test/sll/traverse_1lists.c @@ -0,0 +1,24 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); + SLL_destroy(head1); +} diff --git a/test/sll/traverse_2lists.c b/test/sll/traverse_2lists.c new file mode 100644 index 0000000..8cb7095 --- /dev/null +++ b/test/sll/traverse_2lists.c @@ -0,0 +1,26 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1,head2; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + head2 = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); + SLL_destroy(head1); + SLL_destroy(head2); +} diff --git a/test/sll/traverse_3lists.c b/test/sll/traverse_3lists.c new file mode 100644 index 0000000..f075c4c --- /dev/null +++ b/test/sll/traverse_3lists.c @@ -0,0 +1,28 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1,head2,head3; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + head2 = SLL_create(nondet()); + head3 = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); + SLL_destroy(head1); + SLL_destroy(head2); + SLL_destroy(head3); +} diff --git a/test/sll/traverse_4lists.c b/test/sll/traverse_4lists.c new file mode 100644 index 0000000..3f80bcd --- /dev/null +++ b/test/sll/traverse_4lists.c @@ -0,0 +1,30 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1,head2,head3,head4; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + head2 = SLL_create(nondet()); + head3 = SLL_create(nondet()); + head4 = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); + SLL_destroy(head1); + SLL_destroy(head2); + SLL_destroy(head3); + SLL_destroy(head4); +} diff --git a/test/sll/traverse_5lists.c b/test/sll/traverse_5lists.c new file mode 100644 index 0000000..a7ff7eb --- /dev/null +++ b/test/sll/traverse_5lists.c @@ -0,0 +1,32 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink ; + } +} + +void main(void) { + PSLL_ENTRY head,head1,head2,head3,head4,head5; + + head = SLL_create(nondet()); + head1 = SLL_create(nondet()); + head2 = SLL_create(nondet()); + head3 = SLL_create(nondet()); + head4 = SLL_create(nondet()); + head5 = SLL_create(nondet()); + traverse(head); + SLL_destroy(head); + SLL_destroy(head1); + SLL_destroy(head2); + SLL_destroy(head3); + SLL_destroy(head4); + SLL_destroy(head5); +} diff --git a/test/sll/traverse_seg.c b/test/sll/traverse_seg.c new file mode 100644 index 0000000..c71334d --- /dev/null +++ b/test/sll/traverse_seg.c @@ -0,0 +1,27 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list segment. +**/ + +#include "sll.h" + + +void traverse_seg(PSLL_ENTRY x, PSLL_ENTRY y) { + while(x != y) { + x = x->Flink; + } +} + +void main(void) { + PSLL_ENTRY head, tail; + + tail = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + + head = SLL_create_seg(nondet(), tail); + + traverse_seg(head, tail); + + SLL_destroy_seg(head, tail); + free(tail); +} diff --git a/test/sll/traverse_seg2.c b/test/sll/traverse_seg2.c new file mode 100644 index 0000000..ce7d13c --- /dev/null +++ b/test/sll/traverse_seg2.c @@ -0,0 +1,26 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, and then destroy a singly-linked list segment. + + Similar to traverse_seg.c but the segment might by cyclic or a lasso. +**/ + +#include "sll.h" + + +void traverse_seg(PSLL_ENTRY x, PSLL_ENTRY y) { + while(x != y) { + x = x->Flink; + } +} + +void main(void) { + PSLL_ENTRY head, tail; + + head = SLL_create_seg(nondet(), tail); + + traverse_seg(head, tail); + + SLL_destroy_seg(head, tail); +} diff --git a/test/sll/traverse_twice.c b/test/sll/traverse_twice.c new file mode 100644 index 0000000..f0abedf --- /dev/null +++ b/test/sll/traverse_twice.c @@ -0,0 +1,22 @@ +/** + Copyright (c) Microsoft Corporation. All rights reserved. + + Create, traverse, re-traverse, and then destroy a singly-linked list. +**/ + +#include "sll.h" + +void traverse(PSLL_ENTRY head) { + while(head != NULL) { + head = head->Flink; + } +} + +void main(void) { + PSLL_ENTRY head; + + head = SLL_create(nondet()); + traverse(head); + traverse(head); + SLL_destroy(head); +} diff --git a/test/sll_rec/append_ret_rec.c b/test/sll_rec/append_ret_rec.c new file mode 100644 index 0000000..ef2fddb --- /dev/null +++ b/test/sll_rec/append_ret_rec.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY append(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY r; + + if (x != NULL) { + x->Flink = append(x->Flink, y); + return x; + } else { + return y; + } +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + y = cons(6, y); + y = cons(1, y); + y = cons(4, y); + x = append(x, y); + print_list(x); +} diff --git a/test/sll_rec/create_rec.c b/test/sll_rec/create_rec.c new file mode 100644 index 0000000..7bed13f --- /dev/null +++ b/test/sll_rec/create_rec.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + PSLL_ENTRY head, tmp; + + if (0 <= length) { + tmp = create(length - 1); + head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink = tmp; + } else { + head = NULL; + } + return head; +} + +void main(void) { + int length; + PSLL_ENTRY head, tmp; + + length = length % 100; + tmp = head = create(length); + + print_list(head); +} diff --git a/test/sll_rec/create_rec2.c b/test/sll_rec/create_rec2.c new file mode 100644 index 0000000..c0a679f --- /dev/null +++ b/test/sll_rec/create_rec2.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* like create_rec.c but using length <= 0 instead of 0 <= length */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + PSLL_ENTRY head, tmp; + + if (length <= 0) { + head = NULL; + } else { + tmp = create(length - 1); + head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink = tmp; + } + return head; +} + +void main(void) { + int length; + PSLL_ENTRY head, tmp; + + length = length % 100; + tmp = head = create(length); + + print_list(head); +} diff --git a/test/sll_rec/create_rec3.c b/test/sll_rec/create_rec3.c new file mode 100644 index 0000000..1aed4b1 --- /dev/null +++ b/test/sll_rec/create_rec3.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +/* like create_rec.c but allocate the new link before making the recursive + call, so that the frame is unbounded */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + PSLL_ENTRY head; + + if (0 <= length) { + head = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + head->Flink = create(length - 1); + } else { + head = NULL; + } + return head; +} + +void main(void) { + int length; + PSLL_ENTRY head, tmp; + + length = length % 100; + tmp = head = create(length); + + print_list(head); +} diff --git a/test/sll_rec/destroy_rec.c b/test/sll_rec/destroy_rec.c new file mode 100644 index 0000000..11b4dbf --- /dev/null +++ b/test/sll_rec/destroy_rec.c @@ -0,0 +1,22 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void destroy(PSLL_ENTRY x) { + PSLL_ENTRY t, u; + if (x != NULL) { + t = x; + u = x->Flink; + free(t); + destroy(u); + } +} + +void main() { + PSLL_ENTRY x = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + destroy(x); +} diff --git a/test/sll_rec/find_rec.c b/test/sll_rec/find_rec.c new file mode 100644 index 0000000..3499d9d --- /dev/null +++ b/test/sll_rec/find_rec.c @@ -0,0 +1,20 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +// return first link of x greater than n +PSLL_ENTRY find(PSLL_ENTRY x, int n) { + if (x == NULL) return NULL; + if (x->Data > n) return x; + return find(x->Flink, n); +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + y = find(x, 2); + print_list(y); +} diff --git a/test/sll_rec/insert_rec.c b/test/sll_rec/insert_rec.c new file mode 100644 index 0000000..fee6c04 --- /dev/null +++ b/test/sll_rec/insert_rec.c @@ -0,0 +1,30 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void insert(PSLL_ENTRY *l, PSLL_ENTRY x) { + PSLL_ENTRY u; + if(*l == NULL) { + x->Flink = NULL; + *l = x; + } else { + if(x->Data > (*l)->Data) { + u = (*l)->Flink; + insert(&u, x); + (*l)->Flink = u; + } else { + x->Flink = *l; + *l = x; + } + } +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + insert(&x, cons(3, y)); + print_list(x); +} diff --git a/test/sll_rec/insert_ret_rec.c b/test/sll_rec/insert_ret_rec.c new file mode 100644 index 0000000..e1aa4be --- /dev/null +++ b/test/sll_rec/insert_ret_rec.c @@ -0,0 +1,31 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY insert(PSLL_ENTRY a, PSLL_ENTRY x) { + PSLL_ENTRY l = a; + + if (l == NULL) { + x->Flink = NULL; + return x; + } else { + if (x->Data > l->Data) { + l->Flink = insert(l->Flink, x); + return l; + } else { + x->Flink = l; + return x; + } + } + return l; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + x = insert(x, cons(3, y)); + print_list(x); +} diff --git a/test/sll_rec/insertion_sort_rec.c b/test/sll_rec/insertion_sort_rec.c new file mode 100644 index 0000000..f5ce117 --- /dev/null +++ b/test/sll_rec/insertion_sort_rec.c @@ -0,0 +1,47 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY insert(PSLL_ENTRY a, PSLL_ENTRY x) { + PSLL_ENTRY l = a; + + if (l == NULL) { + x->Flink = NULL; + return x; + } else { + if (x->Data > l->Data) { + l->Flink = insert(l->Flink, x); + return l; + } else { + x->Flink = l; + return x; + } + } + return l; +} + +PSLL_ENTRY insertion_sort(PSLL_ENTRY x) { + PSLL_ENTRY h, ret, cand; + h = x; + ret = NULL; + while (h != NULL) { + cand = h; + h = h->Flink; + cand->Flink = NULL; + ret = insert(ret, cand); + } + return ret; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(1, x); + x = cons(9, x); + x = cons(5, x); + x = cons(7, x); + x = cons(3, x); + print_list(x); printf_s("\n"); + x = insertion_sort(x); + print_list(x); +} diff --git a/test/sll_rec/merge_rec.c b/test/sll_rec/merge_rec.c new file mode 100644 index 0000000..48bd267 --- /dev/null +++ b/test/sll_rec/merge_rec.c @@ -0,0 +1,37 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY merge(PSLL_ENTRY p, PSLL_ENTRY q) { + PSLL_ENTRY r, t; + + if (p == NULL) return q; + if (q == NULL) return p; + if (p->Data <= q->Data) { + r = p->Flink; + t = merge(r, q); + p->Flink = t; + return p; + } else { + r = q->Flink; + t = merge(p, r); + q->Flink = t; + return q; + } + retn: + return r; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL, z; + x = cons(5, x); + x = cons(3, x); + x = cons(1, x); + y = cons(6, y); + y = cons(4, y); + y = cons(2, y); + print_list(x); printf_s("\n"); + print_list(y); printf_s("\n"); + z = merge(x, y); + print_list(z); +} diff --git a/test/sll_rec/merge_rec1.c b/test/sll_rec/merge_rec1.c new file mode 100644 index 0000000..67ea66c --- /dev/null +++ b/test/sll_rec/merge_rec1.c @@ -0,0 +1,33 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY merge(PSLL_ENTRY p, PSLL_ENTRY q) { + PSLL_ENTRY r, t, t2, p2, q2; + if (p == NULL) return q; + if (q == NULL) return p; + if (p->Data <= q->Data) { + t = q; + q2 = q->Flink; + p2 = p; + } else { + t = p; + p2 = p->Flink; + q2 = q; + } + t2 = merge(p2,q2); + t->Flink = t2; + return t; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL, z; + x = cons(5, x); + x = cons(3, x); + x = cons(1, x); + y = cons(6, y); + y = cons(4, y); + y = cons(2, y); + z = merge(x, y); + print_list(z); +} diff --git a/test/sll_rec/merge_sort.c b/test/sll_rec/merge_sort.c new file mode 100644 index 0000000..8617664 --- /dev/null +++ b/test/sll_rec/merge_sort.c @@ -0,0 +1,59 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY merge(PSLL_ENTRY p, PSLL_ENTRY q) { + PSLL_ENTRY r, t; + + if (p == NULL) return q; + if (q == NULL) return p; + if (p->Data <= q->Data) { + r = p->Flink; + t = merge(r, q); + p->Flink = t; + return p; + } else { + r = q->Flink; + t = merge(p, r); + q->Flink = t; + return q; + } + retn: + return r; +} + +PSLL_ENTRY split(PSLL_ENTRY p) { + PSLL_ENTRY t1, t3; + if (p == NULL) return NULL; + t1 = p->Flink; + if (t1 == NULL) return NULL; + t3 = split(t1->Flink); + p->Flink = t1->Flink; + t1->Flink = t3; + return t1; +} + +PSLL_ENTRY merge_sort(PSLL_ENTRY p) { + PSLL_ENTRY q, r; + + if (p == NULL) return NULL; + if (p->Flink == NULL) return p; + q = split(p); + q = merge_sort(q); + p = merge_sort(p); + r = merge(p, q); + return r; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(1, x); + x = cons(9, x); + x = cons(5, x); + x = cons(7, x); + x = cons(3, x); + print_list(x); printf_s("\n"); + x = merge_sort(x); + print_list(x); +} diff --git a/test/sll_rec/quick_sort.c b/test/sll_rec/quick_sort.c new file mode 100644 index 0000000..e20d310 --- /dev/null +++ b/test/sll_rec/quick_sort.c @@ -0,0 +1,41 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY quick_sort(PSLL_ENTRY first, PSLL_ENTRY last) { + PSLL_ENTRY hd, prev, tl, low; + if (first == NULL || first == last) return first; + hd = first; + prev = first; + tl = first->Flink; + while (tl != last) { + if (tl->Data >= prev->Data) { + prev->Flink = tl->Flink; + tl->Flink = hd; + hd = tl; + tl = prev->Flink; + } else { + prev = tl; + tl = tl->Flink; + } + } + tl = first->Flink; + first->Flink = NULL; + prev = NULL; + low = quick_sort(hd, first); + first->Flink = quick_sort(tl, last); + return low; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL, z; + x = cons(4, x); + x = cons(1, x); + x = cons(9, x); + x = cons(5, x); + x = cons(7, x); + x = cons(3, x); + print_list(x); printf_s("\n"); + z = quick_sort(x, NULL); + print_list(z); +} diff --git a/test/sll_rec/remove_rec.c b/test/sll_rec/remove_rec.c new file mode 100644 index 0000000..781a819 --- /dev/null +++ b/test/sll_rec/remove_rec.c @@ -0,0 +1,27 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +void sll_remove(PSLL_ENTRY *l, PSLL_ENTRY x) { + PSLL_ENTRY t; + if(*l != NULL) { + if(*l == x) { + *l = (*l)->Flink; + free(x); + } else { + t = (*l)->Flink; + sll_remove(&t, x); + (*l)->Flink = t; + } + } +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + y = cons(3, y); + y = cons(2, y); + x = cons(1, y); + print_list(x); printf_s("\n"); + sll_remove(&x, y); + print_list(x); +} diff --git a/test/sll_rec/remove_ret_rec.c b/test/sll_rec/remove_ret_rec.c new file mode 100644 index 0000000..f465c75 --- /dev/null +++ b/test/sll_rec/remove_ret_rec.c @@ -0,0 +1,27 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY sll_remove(PSLL_ENTRY a, PSLL_ENTRY x) { + PSLL_ENTRY l = a; + + if (l != NULL) { + if (l == x) { + l = l->Flink; + free(x); + } else { + l->Flink = sll_remove(l->Flink, x); + } + } + return l; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + y = cons(3, y); + y = cons(2, y); + x = cons(1, y); + print_list(x); printf_s("\n"); + x = sll_remove(x, y); + print_list(x); +} diff --git a/test/sll_rec/reverse_app_ret_rec.c b/test/sll_rec/reverse_app_ret_rec.c new file mode 100644 index 0000000..9a58ce9 --- /dev/null +++ b/test/sll_rec/reverse_app_ret_rec.c @@ -0,0 +1,33 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY append(PSLL_ENTRY x, PSLL_ENTRY y) { + if (x != NULL) { + x->Flink = append(x->Flink, y); + return x; + } else { + return y; + } +} + +/* reverse recursively using append */ +PSLL_ENTRY reverse(PSLL_ENTRY x) { + PSLL_ENTRY xf; + + if (x == NULL) return NULL; + xf = x->Flink; + x->Flink = NULL; + return append(reverse(xf), x); +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + x = reverse(x); + print_list(x); +} diff --git a/test/sll_rec/reverse_rec.c b/test/sll_rec/reverse_rec.c new file mode 100644 index 0000000..af52645 --- /dev/null +++ b/test/sll_rec/reverse_rec.c @@ -0,0 +1,26 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +typedef struct _SLL_ENTRY cell, *list, *listseg; + +list list_reverse_rec_aux(list x, list y) { + if(y == NULL) { + return x; + } else { + list tmp = y->Flink; + y->Flink = x; + return list_reverse_rec_aux(y, tmp); + } +} + +void list_reverse(list *z) { + *z = list_reverse_rec_aux(NULL, *z); +} + +int main() { + list x; + x = cons(1, cons(2, cons(3, NULL))); + list_reverse(&x); + print_list(x); printf_s("\n"); +} diff --git a/test/sll_rec/reverse_ret_rec.c b/test/sll_rec/reverse_ret_rec.c new file mode 100644 index 0000000..3b311bd --- /dev/null +++ b/test/sll_rec/reverse_ret_rec.c @@ -0,0 +1,30 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY reverse(PSLL_ENTRY a) { + PSLL_ENTRY x = a; + PSLL_ENTRY t, r; + + if (x != NULL) { + t = x->Flink; + if (t != NULL) { + x->Flink = NULL; + r = reverse(t); + t->Flink = x; + return r; + } + } + return x; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL; + x = cons(4, x); + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + x = reverse(x); + print_list(x); +} diff --git a/test/sll_rec/splice_rec.c b/test/sll_rec/splice_rec.c new file mode 100644 index 0000000..f1564ca --- /dev/null +++ b/test/sll_rec/splice_rec.c @@ -0,0 +1,29 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY splice(PSLL_ENTRY x, PSLL_ENTRY y) { + PSLL_ENTRY t; + + t = y; + if (x != NULL) { + x->Flink = splice(y, x->Flink); + t = x; + } + return t; +} + +void main() { + PSLL_ENTRY x = NULL, y = NULL, z; + x = cons(3, x); + x = cons(2, x); + x = cons(1, x); + y = cons(7, y); + y = cons(6, y); + y = cons(5, y); + y = cons(4, y); + print_list(x); printf_s("\n"); + print_list(y); printf_s("\n"); + z = splice(x, y); + print_list(z); +} diff --git a/test/sll_rec/split.c b/test/sll_rec/split.c new file mode 100644 index 0000000..78719e1 --- /dev/null +++ b/test/sll_rec/split.c @@ -0,0 +1,28 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY split(PSLL_ENTRY p) { + PSLL_ENTRY t1, t3; + if (p == NULL) return NULL; + t1 = p->Flink; + if (t1 == NULL) return NULL; + t3 = split(t1->Flink); + p->Flink = t1->Flink; + t1->Flink = t3; + return t1; +} + +void main() { + PSLL_ENTRY x = NULL, y; + x = cons(6, x); + x = cons(4, x); + x = cons(2, x); + x = cons(5, x); + x = cons(3, x); + x = cons(1, x); + print_list(x); printf_s("\n"); + y = split(x); + print_list(x); printf_s("\n"); + print_list(y); +} diff --git a/test/sll_rec/traverse_rec.c b/test/sll_rec/traverse_rec.c new file mode 100644 index 0000000..584ba66 --- /dev/null +++ b/test/sll_rec/traverse_rec.c @@ -0,0 +1,36 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; i < length; i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY x) { + if(x != NULL) { + traverse(x->Flink); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head); +/* traverse(head); */ + + return; +} diff --git a/test/sll_rec/traverse_rec_nondet.c b/test/sll_rec/traverse_rec_nondet.c new file mode 100644 index 0000000..3b5cd66 --- /dev/null +++ b/test/sll_rec/traverse_rec_nondet.c @@ -0,0 +1,36 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; nondet(); i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY x) { + if(x != NULL) { + traverse(x->Flink); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head); +/* traverse(head); */ + + return; +} diff --git a/test/sll_rec/traverse_seg_rec.c b/test/sll_rec/traverse_seg_rec.c new file mode 100644 index 0000000..98741a6 --- /dev/null +++ b/test/sll_rec/traverse_seg_rec.c @@ -0,0 +1,39 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; i < length; i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY a, PSLL_ENTRY y) { + PSLL_ENTRY x = a; + + if(x != y) { + x = x->Flink; + traverse(x, y); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head, NULL); +/* traverse(head); */ + + return; +} diff --git a/test/sll_rec/traverse_seg_rec_nondet.c b/test/sll_rec/traverse_seg_rec_nondet.c new file mode 100644 index 0000000..27e189d --- /dev/null +++ b/test/sll_rec/traverse_seg_rec_nondet.c @@ -0,0 +1,39 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +#include "sll.h" + +PSLL_ENTRY create(int length) { + int i; + PSLL_ENTRY head, tmp; + + head = NULL; + for(i = 0; nondet(); i++) { + tmp = (PSLL_ENTRY)malloc(sizeof(SLL_ENTRY)); + tmp->Flink = head; + head = tmp; + } + + return head; +} + +void traverse(PSLL_ENTRY a, PSLL_ENTRY y) { + PSLL_ENTRY x = a; + + if(x != y) { + x = x->Flink; + traverse(x, y); + } +} + +void main(void) { + int length; + PSLL_ENTRY head; + + length = length % 100; + head = create(length); + + traverse(head, NULL); +/* traverse(head); */ + + return; +} diff --git a/test/ssa/branch.c b/test/ssa/branch.c new file mode 100644 index 0000000..2fbd6ae --- /dev/null +++ b/test/ssa/branch.c @@ -0,0 +1,18 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +// simple branch + +#include "slayer.h" + +void main() { + int x; + + x = 0; + if (nondet()) { + x = x + 1; + } else { + x = x + 2; + } + x = x + 3; + +} diff --git a/test/ssa/dloop.c b/test/ssa/dloop.c new file mode 100644 index 0000000..331e5ea --- /dev/null +++ b/test/ssa/dloop.c @@ -0,0 +1,19 @@ +/* Copyright (c) Microsoft Corporation. All rights reserved. */ + +// Two loops using [head] variable + +#include "slayer.h" + +void main() { + int i, j; + int head = 0; + int length = nondet(); + + for (i=0; i