├── VERSION ├── bin └── .gitignore ├── etc └── .gitignore ├── LICENSE-en ├── LICENSE-fr ├── .gitignore ├── man └── ocamlclean.1.gz ├── dist ├── ocamlclean-1.6.tar.bz2 ├── ocamlclean-1.7.tar.bz2 ├── ocamlclean-1.8.tar.bz2 ├── ocamlclean-1.9.tar.bz2 ├── ocamlclean-2.0.tar.bz2 ├── ocamlclean-2.1.tar.bz2 ├── ocamlclean-2.0.5.tar.bz2 └── distgen ├── README ├── src ├── cleanbra.ml ├── Makefile ├── rmnop.ml ├── step3.ml ├── dump.ml ├── data.ml ├── globalise.ml ├── prim.ml ├── main.ml ├── step1.ml ├── cleanenvs.ml └── step2.ml ├── Makefile ├── INSTALL └── configure /VERSION: -------------------------------------------------------------------------------- 1 | 2.3 2 | -------------------------------------------------------------------------------- /bin/.gitignore: -------------------------------------------------------------------------------- 1 | * 2 | !.gitignore 3 | -------------------------------------------------------------------------------- /etc/.gitignore: -------------------------------------------------------------------------------- 1 | * 2 | !.gitignore 3 | -------------------------------------------------------------------------------- /LICENSE-en: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/LICENSE-en -------------------------------------------------------------------------------- /LICENSE-fr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/LICENSE-fr -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | src/_build/ 2 | src/config.ml 3 | etc/Makefile.conf 4 | etc/config.ml 5 | -------------------------------------------------------------------------------- /man/ocamlclean.1.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/man/ocamlclean.1.gz -------------------------------------------------------------------------------- /dist/ocamlclean-1.6.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/dist/ocamlclean-1.6.tar.bz2 -------------------------------------------------------------------------------- /dist/ocamlclean-1.7.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/dist/ocamlclean-1.7.tar.bz2 -------------------------------------------------------------------------------- /dist/ocamlclean-1.8.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/dist/ocamlclean-1.8.tar.bz2 -------------------------------------------------------------------------------- /dist/ocamlclean-1.9.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/dist/ocamlclean-1.9.tar.bz2 -------------------------------------------------------------------------------- /dist/ocamlclean-2.0.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/dist/ocamlclean-2.0.tar.bz2 -------------------------------------------------------------------------------- /dist/ocamlclean-2.1.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/dist/ocamlclean-2.1.tar.bz2 -------------------------------------------------------------------------------- /dist/ocamlclean-2.0.5.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bvaugon/ocamlclean/HEAD/dist/ocamlclean-2.0.5.tar.bz2 -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | OCaml Bytecode Cleaner. 2 | 3 | See the OCaPIC project (http://www.algo-prog.info/ocapic/web/index.php?id=ocapic) for more informations. 4 | -------------------------------------------------------------------------------- /src/cleanbra.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | open OByteLib.Normalised_instr 13 | 14 | let clean code = 15 | let f i bc = 16 | match bc with 17 | | BRANCH ptr | BRANCHIF ptr | BRANCHIFNOT ptr | COMPBRANCH (_, _, ptr) -> 18 | if ptr = i + 1 then code.(i) <- Step1.nop; 19 | | _ -> () 20 | in 21 | Array.iteri f code; 22 | ;; 23 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | ########################################################################### 2 | ## ## 3 | ## OCamlClean ## 4 | ## ## 5 | ## Benoit Vaugon ## 6 | ## ## 7 | ## This file is distributed under the terms of the CeCILL license. ## 8 | ## See file ../LICENSE-en. ## 9 | ## ## 10 | ########################################################################### 11 | 12 | include ../etc/Makefile.conf 13 | 14 | TARG = $(BIN)/ocamlclean 15 | SRCS = $(wildcard *.ml) 16 | BUILD = main.native 17 | 18 | ocamlclean: $(TARG) 19 | 20 | $(TARG): _build/$(BUILD) 21 | cp $< $@ 22 | 23 | _build/$(BUILD): $(SRCS) config.ml 24 | $(OCAMLBUILD) -cflags -I,+../obytelib,-g -lflags -I,+../obytelib,obytelib.cmxa $(BUILD) 25 | 26 | config.ml: $(ETC)/config.ml 27 | cp $< $@ 28 | 29 | clean: 30 | @$(OCAMLBUILD) -clean 31 | @rm -f *~ config.ml $(TARG) 32 | 33 | .PHONY: ocamlclean clean 34 | -------------------------------------------------------------------------------- /dist/distgen: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | ########################################################################### 3 | ## ## 4 | ## OCamlClean ## 5 | ## ## 6 | ## Benoit Vaugon ## 7 | ## ## 8 | ## This file is distributed under the terms of the CeCILL license. ## 9 | ## See file ../LICENSE-en. ## 10 | ## ## 11 | ########################################################################### 12 | 13 | cd $(dirname "$0") 14 | 15 | VERSION=$(cat ../VERSION) 16 | DEST=ocamlclean-"$VERSION" 17 | 18 | for d in "$DEST" "$DEST/dist" "$DEST/etc"; do 19 | mkdir "$d" 20 | done 21 | 22 | for d in \ 23 | bin configure INSTALL LICENSE-fr LICENSE-en Makefile man src VERSION; 24 | do 25 | cp -R ../"$d" "$DEST/" 26 | done 27 | 28 | cp ./distgen "$DEST/dist/" 29 | 30 | tar jcf "$DEST.tar.bz2" "$DEST" 31 | 32 | rm -Rf "$DEST" 33 | 34 | echo "** Distribution $DEST.tar.bz2 created successfully **" 35 | -------------------------------------------------------------------------------- /src/rmnop.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | let compute_map orig_code = 13 | let nb_instr = Array.length orig_code in 14 | let map = Array.make nb_instr 0 in 15 | let rec f i j = 16 | if i < nb_instr then ( 17 | map.(i) <- j; 18 | if orig_code.(i) = Step1.nop 19 | then f (succ i) j 20 | else f (succ i) (succ j) 21 | ) 22 | in 23 | f 0 0; 24 | map 25 | ;; 26 | 27 | let compress orig_code map = 28 | let orig_size = Array.length orig_code in 29 | let new_size = map.(Array.length map - 1) + 1 in 30 | let new_code = Array.make new_size Step1.nop in 31 | for i = 0 to orig_size - 1 do 32 | if orig_code.(i) <> Step1.nop 33 | then new_code.(map.(i)) <- orig_code.(i); 34 | done; 35 | new_code 36 | ;; 37 | 38 | let clean orig_code = 39 | let map = compute_map orig_code in 40 | let new_code = compress orig_code map in 41 | Array.map (Step1.remap_instr map) new_code 42 | ;; 43 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ########################################################################### 2 | ## ## 3 | ## OCamlClean ## 4 | ## ## 5 | ## Benoit Vaugon ## 6 | ## ## 7 | ## This file is distributed under the terms of the CeCILL license. ## 8 | ## See file LICENSE-en. ## 9 | ## ## 10 | ########################################################################### 11 | 12 | include etc/Makefile.conf 13 | 14 | all: config 15 | $(call compile, src) 16 | 17 | config: 18 | @if [ $(ETC)/Makefile.conf -ot VERSION -o \ 19 | $(ETC)/Makefile.conf -ot configure ]; then \ 20 | echo 'Configuration files are not up to date.' 1>&2; \ 21 | echo 'Please run `./configure` (with right options).' 1>&2; \ 22 | exit 1; \ 23 | fi 24 | 25 | install: all 26 | mkdir -p "$(BINDIR)" 27 | mkdir -p "$(MAN1DIR)" 28 | cp bin/ocamlclean "$(BINDIR)/ocamlclean" 29 | cp man/ocamlclean.1.gz "$(MAN1DIR)/ocamlclean.1.gz" 30 | 31 | uninstall: 32 | -rm -f "$(BINDIR)/ocamlclean" 33 | -rm -f "$(MAN1DIR)/ocamlclean.1.gz" 34 | 35 | etc/Makefile.conf: 36 | @echo "You must run ./configure before" 1>&2 37 | @exit 1 38 | 39 | dist: clean 40 | dist/distgen 41 | 42 | clean: 43 | @rm -f *~ */*~ */*/*~ 44 | $(call clean, src) 45 | 46 | .PHONY: all config install uninstall dist clean 47 | -------------------------------------------------------------------------------- /src/step3.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | open OByteLib.Normalised_instr 13 | 14 | let compute_used code = 15 | let nb_instr = Array.length code in 16 | let used = Array.make nb_instr false in 17 | let rec f i = 18 | if i < nb_instr && not used.(i) then ( 19 | used.(i) <- true; 20 | match code.(i) with 21 | | BRANCH ptr -> 22 | f ptr 23 | | BRANCHIF ptr | BRANCHIFNOT ptr | COMPBRANCH (_, _, ptr) 24 | | PUSH_RETADDR ptr | CLOSURE (_, ptr) | PUSHTRAP ptr -> 25 | f (succ i); 26 | f ptr; 27 | | CLOSUREREC (_, ptrs) -> 28 | f (succ i); 29 | Array.iter f ptrs; 30 | | SWITCH (iptrs, pptrs) -> 31 | Array.iter f iptrs; 32 | Array.iter f pptrs; 33 | | GRAB _ -> f (pred i) ; f (succ i) 34 | | RETURN _ | APPTERM (_, _) | STOP | RAISE | RERAISE | RAISE_NOTRACE -> () 35 | | _ -> 36 | f (succ i) 37 | ) 38 | in 39 | f 0; 40 | used 41 | ;; 42 | 43 | let clean_code code used = 44 | let nb_instr = Array.length code in 45 | for i = 0 to nb_instr - 1 do 46 | if not used.(i) then code.(i) <- Step1.nop; 47 | done 48 | ;; 49 | 50 | let clean code = 51 | let used = compute_used code in 52 | clean_code code used; 53 | ;; 54 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | Installing OCamlClean on a Unix machine 2 | --------------------------------------- 3 | 4 | PREREQUISITES 5 | 6 | * The OCaml standard distribution 7 | 8 | 9 | INSTALLATION INSTRUCTIONS 10 | 11 | 1- Configure the system. From the top directory, do: 12 | 13 | ./configure 14 | 15 | This generates the two configuration files "Makefile.conf" and "config.ml" 16 | in the ./etc/ subdirectory. 17 | 18 | The "configure" script accepts the following options: 19 | 20 | -bindir (default: /usr/local/bin) 21 | Directory where the binaries will be installed. 22 | 23 | -mandir (default: /usr/local/man/man1) 24 | Directory where the manual pages will be installed. 25 | 26 | -prefix (default: /usr/local) 27 | Set bindir and mandir to /bin, /man/man1 respectively. 28 | 29 | 30 | Examples: 31 | 32 | Standard installation in /usr/{bin,man} instead of /usr/local: 33 | ./configure -prefix /usr 34 | 35 | Installation in /usr, man pages in section "l": 36 | ./configure -bindir /usr/bin -mandir /usr/man/manl 37 | 38 | 39 | 2- From the top directory, do: 40 | 41 | make 42 | 43 | This builds the ocamlclean program in directory: ./bin/. 44 | 45 | 46 | 3- You can now install the OCamlClean system. This will create the 47 | following command (in the binary directory selected during 48 | autoconfiguration): 49 | 50 | ocamlclean an OCaml bytecode cleaner 51 | 52 | From the top directory, become superuser and do: 53 | 54 | umask 022 # make sure to give read & execute permission to all 55 | make install 56 | 57 | 4- Installation is complete. Time to clean up. From the toplevel 58 | directory, do: 59 | 60 | make clean 61 | 62 | 63 | UNINSTALLATION INSTRUCTIONS 64 | 65 | 1- If configuration files (./etc/Makefile.conf and ./etc/config.ml) 66 | have been lost, run again ./configure from the top directory with the 67 | same options as at step 1 of installation. 68 | 69 | 2- From the top directory, become superuser and do: 70 | 71 | make uninstall 72 | -------------------------------------------------------------------------------- /src/dump.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | exception Exn of string 13 | 14 | let buf_len = Sys.max_array_length 15 | 16 | let import ic length = 17 | let mem_size = length / buf_len + 1 in 18 | let mem = Array.make mem_size [||] in 19 | for i = 0 to mem_size - 2 do mem.(i) <- Array.make buf_len (-1) done; 20 | mem.(mem_size - 1) <- Array.make (length - buf_len * (mem_size - 1)) (-1); 21 | let rec fill i j cpt = 22 | if cpt <> 0 then 23 | if j = buf_len then fill (succ i) 0 cpt 24 | else ( 25 | mem.(i).(j) <- input_byte ic; 26 | fill i (succ j) (pred cpt); 27 | ) 28 | in 29 | fill 0 0 length; 30 | mem 31 | ;; 32 | 33 | let export oc = Array.iter (Array.iter (output_byte oc));; 34 | 35 | let size mem = Array.fold_left (fun acc tbl -> acc + Array.length tbl) 0 mem;; 36 | 37 | let parse ic index section = 38 | try 39 | let (offset, length) = OByteLib.Index.find_section index section in 40 | seek_in ic offset; 41 | (section, import ic length) 42 | with Not_found -> (section, [||]) 43 | ;; 44 | 45 | let parse_beginning ic index = 46 | let rec compute_min min rest = 47 | match rest with 48 | | [] -> min 49 | | (_, offset, _) :: tl -> 50 | if offset < min then compute_min offset tl else compute_min min tl 51 | in 52 | let size = compute_min (in_channel_length ic) index in 53 | seek_in ic 0; 54 | import ic size 55 | ;; 56 | -------------------------------------------------------------------------------- /src/data.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | open OByteLib.Normalised_instr 13 | 14 | exception Exn of string 15 | 16 | let parse ic index = 17 | let (offset, _) = 18 | try 19 | OByteLib.Index.find_section index OByteLib.Section.DATA 20 | with Not_found -> 21 | raise (Exn "code section not found") 22 | in 23 | seek_in ic offset; 24 | let (data : Obj.t array) = input_value ic in 25 | data 26 | ;; 27 | 28 | let clean code orig_data = 29 | let nb_data = Array.length orig_data in 30 | let nb_instr = Array.length code in 31 | let map = Array.make nb_data None in 32 | let invmap = Array.make nb_data 0 in 33 | let counter = ref 12 in 34 | let remap p = 35 | match map.(p) with 36 | | None -> 37 | let new_p = !counter in 38 | counter := succ new_p; 39 | map.(p) <- Some new_p; 40 | invmap.(new_p) <- p; 41 | new_p 42 | | Some new_p -> new_p 43 | in 44 | for i = 0 to !counter - 1 do 45 | map.(i) <- Some i; 46 | invmap.(i) <- i; 47 | done; 48 | for i = 0 to nb_instr - 1 do 49 | match code.(i) with 50 | | GETGLOBAL p -> code.(i) <- GETGLOBAL (remap p); 51 | | _ -> () 52 | done; 53 | for i = 0 to nb_instr - 1 do 54 | match code.(i) with 55 | | SETGLOBAL p -> 56 | begin match map.(p) with 57 | | None -> code.(i) <- Step1.nop; 58 | | Some new_p -> code.(i) <- SETGLOBAL new_p; 59 | end 60 | | _ -> () 61 | done; 62 | let new_data = Array.init !counter (fun p -> orig_data.(invmap.(p))) in 63 | new_data 64 | ;; 65 | 66 | let export oc data = 67 | output_value oc data; 68 | ;; 69 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | ########################################################################### 3 | ## ## 4 | ## OCamlClean ## 5 | ## ## 6 | ## Benoit Vaugon ## 7 | ## ## 8 | ## This file is distributed under the terms of the CeCILL license. ## 9 | ## See file LICENSE-en. ## 10 | ## ## 11 | ########################################################################### 12 | 13 | function error () { 14 | echo "$@" 1>&2 15 | exit 1 16 | } 17 | 18 | function usage () { 19 | echo "$@" 1>&2 20 | error "Usage: $0 [ -prefix ] [ -bindir ] [ -mandir ]" 21 | } 22 | 23 | ### 24 | 25 | OCAMLOPT="$(ocamlc -where)/../../bin/ocamlopt" 26 | OCAMLC="$(ocamlc -where)/../../bin/ocamlc" 27 | OCAMLBUILD="$(ocamlc -where)/../../bin/ocamlbuild" 28 | VERSION="$(cat VERSION)" 29 | PWD="$(pwd)" 30 | 31 | ### 32 | 33 | BINDIR=/usr/local/bin 34 | MANDIR=/usr/local/man 35 | 36 | while [ $# -ne 0 ]; do 37 | case "$1" in 38 | -bindir) BINDIR="$2"; shift ;; 39 | -mandir) MANDIR="$2"; shift ;; 40 | -prefix) 41 | BINDIR="$2"/bin 42 | MANDIR="$2"/man 43 | shift;; 44 | *) 45 | usage "Don't know what to do with \"$1\"" 46 | esac 47 | shift 48 | done 49 | 50 | ### 51 | 52 | echo -n "\ 53 | BINDIR = $BINDIR 54 | MAN1DIR = $MANDIR/man1 55 | OCAMLC = $OCAMLC -w @a-4-70 -warn-error A -safe-string -strict-formats -strict-sequence 56 | OCAMLOPT = $OCAMLOPT -w @a-4-70 -warn-error A -safe-string -strict-formats -strict-sequence 57 | OCAMLC_UNSAFE = $OCAMLC 58 | OCAMLBUILD = $OCAMLBUILD -cflags -w,@a-4-70,-warn-error,A,-safe-string,-strict-formats,-strict-sequence -lflags -w,@a-4-70,-warn-error,A,-safe-string,-strict-formats,-strict-sequence -no-links -classic-display 59 | BIN = $PWD/bin 60 | ETC = $PWD/etc 61 | DIST = $PWD/dist 62 | define compile 63 | @make --no-print-directory -q -C \$1 && \ 64 | make --no-print-directory -C \$1 || \ 65 | make -C \$1 66 | endef 67 | define clean 68 | @make --no-print-directory -C \$1 clean > /dev/null 69 | endef 70 | " > etc/Makefile.conf 71 | 72 | ### 73 | 74 | echo -n "\ 75 | let ocamlc = \"$OCAMLC\" 76 | let ocamlclean = \"$BINDIR/ocamlclean\" 77 | let version = \"$VERSION\" 78 | " > etc/config.ml 79 | 80 | ### 81 | 82 | echo "** OCamlClean configuration completed successfully **" 83 | -------------------------------------------------------------------------------- /src/globalise.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | open OByteLib.Normalised_instr 13 | 14 | let globalise code old_data_nb map = 15 | let glob_counter = ref old_data_nb in 16 | fun (setg_ind, nb_fields) -> 17 | match code.(setg_ind - 1), code.(setg_ind) with 18 | | POP popn, SETGLOBAL glob_ind -> 19 | map.(glob_ind) <- Some !glob_counter; 20 | for i = 0 to nb_fields - 1 do 21 | let acc_ind = setg_ind - 3 - 2 * i in 22 | match code.(acc_ind) with 23 | | ACC old_ofs -> 24 | code.(acc_ind) <- 25 | ACC (old_ofs + i - nb_fields + 1); 26 | code.(acc_ind + 1) <- SETGLOBAL !glob_counter; 27 | incr glob_counter; 28 | | _ -> assert false 29 | done; 30 | code.(setg_ind - 1) <- POP (popn - nb_fields); 31 | | _ -> assert false 32 | ;; 33 | 34 | let remap_globals map code = 35 | for i = 0 to Array.length code - 2 do 36 | match code.(i), code.(i + 1) with 37 | | GETGLOBAL g_ind, GETFIELD f_ind -> 38 | begin match map.(g_ind) with 39 | | Some new_ind -> 40 | code.(i) <- GETGLOBAL (new_ind + f_ind); 41 | code.(i + 1) <- Step1.nop; 42 | | None -> () 43 | end 44 | | _ -> () 45 | done; 46 | ;; 47 | 48 | let globalise_closures old_code old_data = 49 | let cleanables = Step1.compute_cleanables old_code old_data in 50 | let (new_code, cleans) = Step1.prepare_code old_code cleanables false in 51 | let old_data_nb = Array.length old_data in 52 | let code_info = List.map (fun (i, l) -> (i, List.length l)) cleans in 53 | let new_data_nb = List.fold_left (fun a (_,l) -> a+l) old_data_nb code_info in 54 | let new_data = Array.make new_data_nb (Obj.repr 0) in 55 | let map = Array.make old_data_nb None in 56 | Array.blit old_data 0 new_data 0 old_data_nb; 57 | List.iter (globalise new_code old_data_nb map) code_info; 58 | remap_globals map new_code; 59 | let new_code = Rmnop.clean new_code in 60 | (new_code, Data.clean new_code new_data) 61 | ;; 62 | -------------------------------------------------------------------------------- /src/prim.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | exception Exn of string 13 | 14 | let clean code orig_prim = 15 | let nb_instr = Array.length code in 16 | let nb_prim = Array.length orig_prim in 17 | let map = Array.make nb_prim None in 18 | let invmap = Array.make nb_prim 0 in 19 | let counter = ref 0 in 20 | let remap p = 21 | match map.(p) with 22 | | None -> 23 | let new_p = !counter in 24 | counter := succ new_p; 25 | map.(p) <- Some new_p; 26 | invmap.(new_p) <- p; 27 | new_p 28 | | Some new_p -> new_p 29 | in 30 | for i = 0 to nb_instr - 1 do 31 | match code.(i) with 32 | | OByteLib.Normalised_instr.C_CALL (n, p) -> code.(i) <- OByteLib.Normalised_instr.C_CALL (n, remap p); 33 | | _ -> () 34 | done; 35 | let new_prim = Array.init !counter (fun p -> orig_prim.(invmap.(p))) in 36 | new_prim 37 | ;; 38 | 39 | let no_side_effect prim_name = 40 | match prim_name with 41 | | "caml_alloc_dummy" 42 | | "caml_alloc_dummy_float" 43 | | "caml_array_unsafe_get_float" 44 | | "caml_array_unsafe_get" 45 | | "caml_float_of_string" 46 | | "caml_int_of_float" 47 | | "caml_float_of_int" 48 | | "caml_neg_float" 49 | | "caml_abs_float" 50 | | "caml_add_float" 51 | | "caml_sub_float" 52 | | "caml_mul_float" 53 | | "caml_div_float" 54 | | "caml_exp_float" 55 | | "caml_floor_float" 56 | | "caml_fmod_float" 57 | | "caml_frexp_float" 58 | | "caml_ldexp_float" 59 | | "caml_log_float" 60 | | "caml_log10_float" 61 | | "caml_modf_float" 62 | | "caml_sqrt_float" 63 | | "caml_power_float" 64 | | "caml_sin_float" 65 | | "caml_sinh_float" 66 | | "caml_cos_float" 67 | | "caml_cosh_float" 68 | | "caml_tan_float" 69 | | "caml_tanh_float" 70 | | "caml_asin_float" 71 | | "caml_acos_float" 72 | | "caml_atan_float" 73 | | "caml_atan2_float" 74 | | "caml_ceil_float" 75 | | "caml_eq_float" 76 | | "caml_neq_float" 77 | | "caml_le_float" 78 | | "caml_lt_float" 79 | | "caml_ge_float" 80 | | "caml_gt_float" 81 | | "caml_float_compare" 82 | | "caml_classify_float" 83 | | "caml_gc_stat" 84 | | "caml_gc_quick_stat" 85 | | "caml_gc_counters" 86 | | "caml_gc_get" 87 | | "caml_int_compare" 88 | | "caml_int32_neg" 89 | | "caml_int32_add" 90 | | "caml_int32_sub" 91 | | "caml_int32_mul" 92 | | "caml_int32_and" 93 | | "caml_int32_or" 94 | | "caml_int32_xor" 95 | | "caml_int32_shift_left" 96 | | "caml_int32_shift_right" 97 | | "caml_int32_shift_right_unsigned" 98 | | "caml_int32_of_int" 99 | | "caml_int32_to_int" 100 | | "caml_int32_of_float" 101 | | "caml_int32_to_float" 102 | | "caml_int32_compare" 103 | | "caml_int32_bits_of_float" 104 | | "caml_int32_float_of_bits" 105 | | "caml_int64_neg" 106 | | "caml_int64_add" 107 | | "caml_int64_sub" 108 | | "caml_int64_mul" 109 | | "caml_int64_and" 110 | | "caml_int64_or" 111 | | "caml_int64_xor" 112 | | "caml_int64_shift_left" 113 | | "caml_int64_shift_right" 114 | | "caml_int64_shift_right_unsigned" 115 | | "caml_int64_of_int" 116 | | "caml_int64_to_int" 117 | | "caml_int64_of_float" 118 | | "caml_int64_to_float" 119 | | "caml_int64_of_int32" 120 | | "caml_int64_to_int32" 121 | | "caml_int64_of_nativeint" 122 | | "caml_int64_to_nativeint" 123 | | "caml_int64_compare" 124 | | "caml_int64_bits_of_float" 125 | | "caml_int64_float_of_bits" 126 | | "caml_nativeint_neg" 127 | | "caml_nativeint_add" 128 | | "caml_nativeint_sub" 129 | | "caml_nativeint_mul" 130 | | "caml_nativeint_and" 131 | | "caml_nativeint_or" 132 | | "caml_nativeint_xor" 133 | | "caml_nativeint_shift_left" 134 | | "caml_nativeint_shift_right" 135 | | "caml_nativeint_shift_right_unsigned" 136 | | "caml_nativeint_of_int" 137 | | "caml_nativeint_to_int" 138 | | "caml_nativeint_of_float" 139 | | "caml_nativeint_to_float" 140 | | "caml_nativeint_of_int32" 141 | | "caml_nativeint_to_int32" 142 | | "caml_nativeint_compare" 143 | | "caml_static_alloc" 144 | | "caml_obj_is_block" 145 | | "caml_obj_tag" 146 | | "caml_obj_block" 147 | | "caml_obj_dup" 148 | | "caml_lazy_make_forward" 149 | | "caml_get_public_method" 150 | | "caml_ml_string_length" 151 | | "caml_string_equal" 152 | | "caml_string_notequal" 153 | | "caml_string_compare" 154 | | "caml_string_lessthan" 155 | | "caml_string_lessequal" 156 | | "caml_string_greaterthan" 157 | | "caml_string_greaterequal" 158 | | "caml_is_printable" -> true 159 | | _ -> false 160 | ;; 161 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | let source_file = ref None in 13 | let dest_file = ref "a.out" in 14 | let verbose = ref false in 15 | let spec = 16 | Arg.align [ 17 | ("-o", Arg.Set_string dest_file, 18 | Printf.sprintf " Define output filename (default: %s)" 19 | !dest_file); 20 | ("-verbose", Arg.Set verbose, " Verbose mode"); 21 | ("-version", Arg.Unit (fun () -> print_endline Config.version ; exit 0), 22 | " Print version and exit"); 23 | ] in 24 | let usage = Printf.sprintf "Usage: %s [ OPTIONS ] " Sys.argv.(0) in 25 | let error msg = 26 | Printf.printf "Error: %s\n" msg; 27 | Arg.usage spec usage; 28 | exit 1; 29 | in 30 | let unknow arg = 31 | if !source_file = None then 32 | source_file := Some arg 33 | else 34 | error (Printf.sprintf "don't know what to do with: `%s'" arg); 35 | in 36 | Arg.parse spec unknow usage; 37 | let print_msg = 38 | if !verbose then Printf.printf "%s%!" else fun _ -> () 39 | in 40 | let print_done () = print_msg "done\n" in 41 | let source_file = 42 | match !source_file with 43 | | None -> error "please specify a bytecode file."; 44 | | Some f -> f 45 | in 46 | try 47 | let pass_counter = ref 0 in 48 | let rec compress_loop orig_code prim data = 49 | incr pass_counter; 50 | print_msg (Printf.sprintf " * Pass %d... " !pass_counter); 51 | let code = Step1.clean orig_code data in 52 | let () = Step2.clean code prim in 53 | let () = Step3.clean code in 54 | let data = Data.clean code data in 55 | let () = Cleanbra.clean code in 56 | let code = Rmnop.clean code in 57 | print_done (); 58 | if orig_code = code then 59 | (code, data) 60 | else 61 | compress_loop code prim data 62 | in 63 | print_msg (Printf.sprintf "Loading `%s'... " source_file); 64 | let bytefile = OByteLib.Bytefile.read source_file in 65 | let version = bytefile.OByteLib.Bytefile.version in 66 | let code = OByteLib.Normalised_code.of_code bytefile.OByteLib.Bytefile.code in 67 | let prim = bytefile.OByteLib.Bytefile.prim in 68 | let data = 69 | let data_to_obj = OByteLib.Value.make_to_obj () in 70 | Array.map data_to_obj bytefile.OByteLib.Bytefile.data in 71 | let (_, orig_code_length) = OByteLib.Index.find_section bytefile.OByteLib.Bytefile.index OByteLib.Section.CODE in 72 | let (_, orig_data_length) = OByteLib.Index.find_section bytefile.OByteLib.Bytefile.index OByteLib.Section.DATA in 73 | let (_, orig_prim_length) = OByteLib.Index.find_section bytefile.OByteLib.Bytefile.index OByteLib.Section.PRIM in 74 | let orig_file_length = 75 | let ic = open_in source_file in 76 | let len = in_channel_length ic in 77 | close_in ic; 78 | len in 79 | let orig_instr_nb = Array.length bytefile.OByteLib.Bytefile.code in 80 | let orig_data_nb = Array.length bytefile.OByteLib.Bytefile.data in 81 | let orig_prim_nb = Array.length bytefile.OByteLib.Bytefile.prim in 82 | print_done (); 83 | print_msg "Cleaning code:\n"; 84 | let (code, data) = compress_loop code prim data in 85 | print_msg "Globalising closures... "; 86 | let (code, data) = Globalise.globalise_closures code data in 87 | print_done (); 88 | print_msg "Cleaning environments... "; 89 | let (code, data) = Cleanenvs.clean_environments code data in 90 | print_done (); 91 | print_msg "Cleaning code:\n"; 92 | let (code, data) = compress_loop code prim data in 93 | print_msg "Cleaning primitives... "; 94 | let prim = Prim.clean code prim in 95 | print_done (); 96 | print_msg (Printf.sprintf "Writting `%s'... " !dest_file); 97 | let data = Array.map OByteLib.Value.of_obj data in 98 | let code = OByteLib.Normalised_code.to_code code in 99 | OByteLib.Bytefile.write !dest_file version 100 | ?vmpath:bytefile.OByteLib.Bytefile.vmpath 101 | ?vmarg:bytefile.OByteLib.Bytefile.vmarg 102 | ~extra:bytefile.OByteLib.Bytefile.extra 103 | ~dlpt:bytefile.OByteLib.Bytefile.dlpt 104 | ~dlls:bytefile.OByteLib.Bytefile.dlls 105 | ~crcs:bytefile.OByteLib.Bytefile.crcs 106 | ~symb:bytefile.OByteLib.Bytefile.symb 107 | data prim code; 108 | let (new_code_length, new_data_length, new_prim_length, new_file_length) = 109 | let bytefile = OByteLib.Bytefile.read !dest_file in 110 | let (_, code_length) = OByteLib.Index.find_section bytefile.OByteLib.Bytefile.index OByteLib.Section.CODE in 111 | let (_, data_length) = OByteLib.Index.find_section bytefile.OByteLib.Bytefile.index OByteLib.Section.DATA in 112 | let (_, prim_length) = OByteLib.Index.find_section bytefile.OByteLib.Bytefile.index OByteLib.Section.PRIM in 113 | let ic = open_in !dest_file in 114 | let file_length = in_channel_length ic in 115 | close_in ic; 116 | (code_length, data_length, prim_length, file_length) in 117 | print_done (); 118 | let new_instr_nb = Array.length code in 119 | let new_data_nb = Array.length data in 120 | let new_prim_nb = Array.length prim in 121 | let gain o n = if o = n then 1. else (float_of_int o /. float_of_int n) in 122 | print_msg ( 123 | Printf.sprintf "\n\ 124 | Statistics:\n \ 125 | * Instruction number: %7d -> %7d (/%1.2f)\n \ 126 | * CODE segment length: %7d -> %7d (/%1.2f)\n \ 127 | * Global data number: %7d -> %7d (/%1.2f)\n \ 128 | * DATA segment length: %7d -> %7d (/%1.2f)\n \ 129 | * Primitive number: %7d -> %7d (/%1.2f)\n \ 130 | * PRIM segment length: %7d -> %7d (/%1.2f)\n \ 131 | * File length: %7d -> %7d (/%1.2f)\n\ 132 | " 133 | orig_instr_nb new_instr_nb (gain orig_instr_nb new_instr_nb) 134 | orig_code_length new_code_length (gain orig_code_length new_code_length) 135 | orig_data_nb new_data_nb (gain orig_data_nb new_data_nb) 136 | orig_data_length new_data_length (gain orig_data_length new_data_length) 137 | orig_prim_nb new_prim_nb (gain orig_prim_nb new_prim_nb) 138 | orig_prim_length new_prim_length (gain orig_prim_length new_prim_length) 139 | orig_file_length new_file_length (gain orig_file_length new_file_length) 140 | ); 141 | with 142 | | Sys_error msg -> 143 | error msg 144 | | Failure msg -> 145 | Printf.eprintf "Error: %s\n" msg; 146 | exit 1; 147 | ;; 148 | -------------------------------------------------------------------------------- /src/step1.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | open OByteLib.Normalised_instr 13 | 14 | let nop = POP 0 15 | 16 | let remap_instr ptr_map instr = 17 | let map_ptr ptr = ptr_map.(ptr) in 18 | match instr with 19 | | PUSH_RETADDR ptr -> PUSH_RETADDR (map_ptr ptr) 20 | | CLOSURE (n, ptr) -> CLOSURE (n, map_ptr ptr) 21 | | CLOSUREREC (n, ptrs) -> CLOSUREREC (n, Array.map map_ptr ptrs) 22 | | BRANCH ptr -> BRANCH (map_ptr ptr) 23 | | BRANCHIF ptr -> BRANCHIF (map_ptr ptr) 24 | | BRANCHIFNOT ptr -> BRANCHIFNOT (map_ptr ptr) 25 | | PUSHTRAP ptr -> PUSHTRAP (map_ptr ptr) 26 | | COMPBRANCH (op, n, ptr) -> COMPBRANCH (op, n, map_ptr ptr) 27 | | SWITCH (iptrs, pptrs) -> SWITCH (Array.map map_ptr iptrs, Array.map map_ptr pptrs) 28 | | _ -> instr 29 | ;; 30 | 31 | let remap_code ptr_map new_code = 32 | Array.map (remap_instr ptr_map) new_code 33 | ;; 34 | 35 | let compute_cleanables orig_code data = 36 | let nb_glob = Array.length data in 37 | let setg_counters = Array.make nb_glob 0 in 38 | let getg_counters = Array.make nb_glob 0 in 39 | let getg_fields = Array.make nb_glob [] in 40 | let setg_ind = Array.make nb_glob 0 in 41 | let cleanables = Array.make nb_glob None in 42 | for ind = 0 to Array.length orig_code - 2 do 43 | match orig_code.(ind), orig_code.(ind + 1) with 44 | | GETGLOBAL n, GETFIELD p -> 45 | let l = getg_fields.(n) in 46 | getg_fields.(n) <- if List.mem p l then l else p :: l 47 | | GETGLOBAL n, _ -> 48 | getg_counters.(n) <- succ getg_counters.(n); 49 | | SETGLOBAL n, _ -> 50 | setg_counters.(n) <- succ setg_counters.(n); 51 | setg_ind.(n) <- ind; 52 | | _, _ -> 53 | () 54 | done; 55 | for i = 0 to nb_glob - 1 do 56 | if setg_counters.(i) = 1 && getg_counters.(i) = 0 then 57 | cleanables.(i) <- Some (setg_ind.(i), getg_fields.(i)) 58 | done; 59 | cleanables 60 | ;; 61 | 62 | let compute_branch_targets code = 63 | let nb_instr = Array.length code in 64 | let btargs = Array.make nb_instr false in 65 | Array.iter (fun instr -> 66 | let ptrs = get_ptrs instr in 67 | List.iter (fun ptr -> btargs.(ptr) <- true) ptrs; 68 | ) code; 69 | btargs 70 | ;; 71 | 72 | let prepare_code old_code cleanables ignore_fulls = 73 | let btargs = compute_branch_targets old_code in 74 | let glob_nb = Array.length cleanables in 75 | let add_nb = ref 0 in 76 | let rec f indg adds cleans = 77 | if indg < glob_nb then 78 | match cleanables.(indg) with 79 | | Some (setg_ind, used_fields) -> 80 | if setg_ind >= 2 && not btargs.(setg_ind) && 81 | not btargs.(setg_ind - 1) && not btargs.(setg_ind - 2) 82 | then 83 | match (old_code.(setg_ind - 2), old_code.(setg_ind - 1)) with 84 | | (MAKEBLOCK (_, size), POP popn) -> 85 | let rec g i = 86 | if i >= size then i else 87 | let ind = setg_ind - 4 - 2 * i in 88 | if ind < 0 || btargs.(ind) || btargs.(ind + 1) then 89 | i 90 | else 91 | match (old_code.(ind), old_code.(ind + 1)) with 92 | | (PUSH, ACC _) -> g (i + 1) 93 | | _ -> i 94 | in 95 | let max = g 0 in 96 | if List.length used_fields = size && ignore_fulls then 97 | f (succ indg) adds cleans 98 | else if max < size then ( 99 | old_code.(setg_ind - 1) <- POP (popn + size - max); 100 | add_nb := !add_nb + size - max; 101 | f (succ indg) ((setg_ind, max, size - max) :: adds) 102 | ((setg_ind, used_fields) :: cleans) 103 | ) else 104 | f (succ indg) adds ((setg_ind, used_fields) :: cleans) 105 | | _ -> f (succ indg) adds cleans 106 | else 107 | f (succ indg) adds cleans 108 | | None -> f (succ indg) adds cleans 109 | else 110 | (List.sort compare adds, cleans) 111 | in 112 | let adds, cleans = f 0 [] [] in 113 | let old_code_size = Array.length old_code in 114 | let new_code = Array.make (old_code_size + 2 * !add_nb) nop in 115 | let ptr_map = Array.make old_code_size (-1) in 116 | let rec g adds_rest i j = 117 | match adds_rest with 118 | | (setg_ind, max, add_nb) :: tl -> 119 | let lim_k = setg_ind - 2 - 2 * max in 120 | let rec f k l = 121 | if k = lim_k then 122 | for n = 0 to add_nb - 1 do 123 | new_code.(l + 2 * n) <- PUSH; 124 | new_code.(l + 2 * n + 1) <- ACC (add_nb - 1); 125 | done 126 | else ( 127 | new_code.(l) <- old_code.(k); 128 | ptr_map.(k) <- l; 129 | f (succ k) (succ l); 130 | ) 131 | in 132 | f i j; 133 | for n = 0 to max - 1 do 134 | let k = setg_ind - 3 - 2 * n in 135 | match old_code.(k) with 136 | | ACC p -> old_code.(k) <- ACC (p + add_nb); 137 | | _ -> assert false 138 | done; 139 | g tl lim_k (j + lim_k - i + 2 * add_nb); 140 | | [] -> 141 | let rec f k l = 142 | if k < old_code_size then ( 143 | new_code.(l) <- old_code.(k); 144 | ptr_map.(k) <- l; 145 | f (succ k) (succ l); 146 | ) 147 | in 148 | f i j 149 | in 150 | g adds 0 0; 151 | let new_cleans = 152 | List.map (fun (setg_ind, used_fields) -> (ptr_map.(setg_ind), used_fields)) 153 | cleans 154 | in 155 | let new_code = remap_code ptr_map new_code in 156 | (new_code, new_cleans) 157 | ;; 158 | 159 | let clean_code new_code data cleans = 160 | let data_map = Array.make (Array.length data) [||] in 161 | let update_new_code (setg_ind, used_fields) = 162 | match new_code.(setg_ind-2), new_code.(setg_ind-1), new_code.(setg_ind) with 163 | | MAKEBLOCK (mbt, mbs), POP pn, SETGLOBAL sgn -> 164 | let nb_used_fields = List.length used_fields in 165 | let cpt = ref 0 in 166 | data_map.(sgn) <- Array.make mbs (-1); 167 | List.iter (fun n -> data_map.(sgn).(n) <- 0) used_fields; 168 | for i = 0 to mbs - 1 do 169 | if data_map.(sgn).(i) = -1 then ( 170 | new_code.(setg_ind - 4 - 2 * i) <- nop; 171 | new_code.(setg_ind - 3 - 2 * i) <- nop; 172 | ) else ( 173 | data_map.(sgn).(i) <- !cpt; 174 | incr cpt; 175 | ) 176 | done; 177 | cpt := 0; 178 | for i = mbs - 1 downto 0 do 179 | if data_map.(sgn).(i) = -1 then 180 | incr cpt 181 | else 182 | match new_code.(setg_ind - 3 - 2 * i) with 183 | | ACC k -> new_code.(setg_ind - 3 - 2 * i) <- ACC (k - !cpt) 184 | | _ -> assert false 185 | done; 186 | if nb_used_fields <> 0 then 187 | new_code.(setg_ind-2) <- MAKEBLOCK (mbt, nb_used_fields) 188 | else 189 | new_code.(setg_ind-2) <- ATOM mbt; 190 | if nb_used_fields = 0 then new_code.(setg_ind-1) <- POP (pn - 1); 191 | | _ -> assert false 192 | in 193 | List.iter update_new_code cleans; 194 | for i = 0 to Array.length new_code - 2 do 195 | match new_code.(i), new_code.(i + 1) with 196 | | GETGLOBAL n, GETFIELD p -> 197 | if data_map.(n) <> [||] then new_code.(i + 1) <- GETFIELD data_map.(n).(p); 198 | | _ -> 199 | () 200 | done 201 | ;; 202 | 203 | let clean old_code data = 204 | let cleanables = compute_cleanables old_code data in 205 | let (new_code, cleans) = prepare_code old_code cleanables true in 206 | clean_code new_code data cleans; 207 | new_code 208 | ;; 209 | -------------------------------------------------------------------------------- /src/cleanenvs.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | open OByteLib.Normalised_instr 13 | 14 | type mark = Unused | Valid | Invalid 15 | 16 | let compute_nexts code = 17 | let f i bc = 18 | match bc with 19 | | APPLY n when n > 3 -> [] 20 | | instr -> get_nexts i instr in 21 | Array.mapi f code 22 | ;; 23 | 24 | let compute_marks code = 25 | let nexts = compute_nexts code in 26 | let nb_instr = Array.length code in 27 | let marks = Array.make nb_instr Unused in 28 | let passes = Array.make nb_instr Unused in 29 | let rec f i = 30 | match (marks.(i), passes.(i)) with 31 | | (Unused, Unused) -> 32 | marks.(i) <- Valid; 33 | passes.(i) <- Valid; 34 | List.iter f nexts.(i); 35 | passes.(i) <- Unused; 36 | 37 | | ((Unused | Valid), Valid) -> 38 | marks.(i) <- Invalid; 39 | passes.(i) <- Invalid; 40 | List.iter f nexts.(i); 41 | passes.(i) <- Valid; 42 | 43 | | _ -> 44 | () 45 | in 46 | f 0; 47 | marks 48 | ;; 49 | 50 | let replace_envaccs code data = 51 | let nb_instr = Array.length code in 52 | let marks = compute_marks code in 53 | let ptr_map = Array.make nb_instr (-1) in 54 | let new_globals = ref [] in 55 | let global_ind = ref (Array.length data) in 56 | let alloc_global ptrs env_ind = 57 | let glob_ind = !global_ind in 58 | let ptrs_nb = Array.length ptrs in 59 | let update_env_assoc env_ofs fun_ptr = 60 | let env_assoc = 61 | try List.assoc fun_ptr !new_globals with Not_found -> 62 | let new_env_assoc = ref [] in 63 | new_globals := (fun_ptr, new_env_assoc) :: !new_globals; 64 | new_env_assoc 65 | in 66 | env_assoc := 67 | (env_ind + 2 * (ptrs_nb - env_ofs - 1), glob_ind) :: !env_assoc; 68 | in 69 | Array.iteri update_env_assoc ptrs; 70 | incr global_ind; 71 | glob_ind 72 | in 73 | let setglobals_of_closure env_size ptrs new_closure = 74 | let rec f i = 75 | if i > env_size then [ new_closure ] else 76 | let glob_ind = alloc_global ptrs i in 77 | ACC 0 :: SETGLOBAL glob_ind :: POP 1 :: f (i + 1) 78 | in 79 | let glob_ind = alloc_global ptrs 1 in 80 | SETGLOBAL glob_ind :: f 2 81 | in 82 | let rec gen_new_code i j acc = 83 | if i = nb_instr then Array.of_list (List.rev acc) else ( 84 | ptr_map.(i) <- j; 85 | match ((marks.(i) = Valid), code.(i)) with 86 | | (true, CLOSURE (env_size, ptr)) when env_size > 0 -> 87 | let new_closure = CLOSURE (0, ptr) in 88 | let instrs = setglobals_of_closure env_size [| ptr |] new_closure in 89 | gen_new_code (i + 1) (j + List.length instrs) (List.rev instrs @ acc) 90 | | (true, CLOSUREREC (env_size, ptrs)) when env_size > 0 -> 91 | let new_closure = CLOSUREREC (0, ptrs) in 92 | let instrs = setglobals_of_closure env_size ptrs new_closure in 93 | gen_new_code (i + 1) (j + List.length instrs) (List.rev instrs @ acc) 94 | | _ -> 95 | gen_new_code (i + 1) (j + 1) (code.(i) :: acc) 96 | ) 97 | in 98 | let new_code = gen_new_code 0 0 [] in 99 | let new_code = Step1.remap_code ptr_map new_code in 100 | let new_nexts = compute_nexts new_code in 101 | let remap_coverage = Array.make (Array.length new_code) false in 102 | let remap_envaccs (fun_ind, env_assoc) = 103 | let rec f i = 104 | if not remap_coverage.(i) then ( 105 | remap_coverage.(i) <- true; 106 | begin match new_code.(i) with 107 | | ENVACC n -> new_code.(i) <- GETGLOBAL (List.assoc n !env_assoc) 108 | | _ -> () 109 | end; 110 | List.iter f new_nexts.(i) 111 | ); 112 | in 113 | f ptr_map.(fun_ind) 114 | in 115 | List.iter remap_envaccs !new_globals; 116 | let new_data = Array.make (Array.length data + !global_ind) (Obj.repr 0) in 117 | Array.blit data 0 new_data 0 (Array.length data); 118 | (new_code, new_data, new_nexts) 119 | ;; 120 | 121 | let factor_globals code data nexts = 122 | let nb_instr = Array.length code in 123 | let marks = compute_marks code in 124 | let (accus, stacks, stack_sizes, _, _, _, _) = Step2.compute_deps code in 125 | let deps = Array.make nb_instr [] in 126 | let data_map = Array.init (Array.length data) (fun i -> i) in 127 | let ptr_map = Array.make nb_instr (-1) in 128 | let rec compute_orig instr_ind pos = 129 | if marks.(instr_ind) <> Valid then None else 130 | match (code.(instr_ind), accus.(instr_ind), stacks.(instr_ind)) with 131 | | (PUSH, [ accu_dep ], _) -> 132 | compute_orig accu_dep 0 133 | | (ACC n, _, stack_deps) -> ( 134 | match stack_deps.(n) with 135 | | [ instr_ind' ] -> 136 | compute_orig instr_ind' (stack_sizes.(instr_ind) - n) 137 | | _ -> 138 | Some (instr_ind, pos) 139 | ) 140 | | _ -> 141 | Some (instr_ind, pos) 142 | in 143 | let compute_deps instr_ind bc = 144 | if marks.(instr_ind) = Valid then 145 | match (bc, accus.(instr_ind)) with 146 | | (SETGLOBAL glob_ind, [accu_dep]) when data.(glob_ind) = Obj.repr 0 -> 147 | begin match compute_orig accu_dep 0 with 148 | | Some (dep_ind, pos) -> 149 | deps.(dep_ind) <- (pos, glob_ind) :: deps.(dep_ind); 150 | code.(instr_ind) <- CONSTINT 0; 151 | | None -> 152 | (); 153 | end; 154 | | _ -> 155 | (); 156 | in 157 | Array.iteri compute_deps code; 158 | (***) 159 | let compute_assoc acc ((pos, glob_ind) as dep) = 160 | try 161 | let shared_glob_ind = List.assoc pos acc in 162 | data_map.(glob_ind) <- shared_glob_ind; 163 | acc 164 | with Not_found -> 165 | dep :: acc 166 | in 167 | let rec gen_new_code i j pra_ofs acc = 168 | if i = nb_instr then (pra_ofs, Array.of_list (List.rev acc)) else ( 169 | ptr_map.(i) <- j; 170 | let assoc = List.fold_left compute_assoc [] deps.(i) in 171 | if assoc = [] then 172 | gen_new_code (i + 1) (j + 1) pra_ofs (code.(i) :: acc) 173 | else 174 | let assoc = List.sort compare assoc in 175 | let gen_rev_instrs acc (pos, glob_ind) = 176 | if pos = 0 then SETGLOBAL glob_ind :: acc 177 | else 178 | let stack_ind = 179 | match nexts.(i) with 180 | | [] -> assert false 181 | | next_ind :: _ -> stack_sizes.(next_ind) - pos + 1 182 | in 183 | SETGLOBAL glob_ind :: ACC stack_ind :: acc 184 | in 185 | let rev_instrs = 186 | POP 1 :: ACC 0 :: 187 | List.fold_left gen_rev_instrs [ PUSH; code.(i) ] assoc 188 | in 189 | let instr_nb = List.length rev_instrs in 190 | let new_pra_ofs = 191 | match code.(i) with 192 | | APPLY n when n >= 4 -> 193 | begin match stacks.(i).(n) with 194 | | [] -> pra_ofs 195 | | pushretaddr_ind :: _ -> 196 | match code.(pushretaddr_ind) with 197 | | PUSH_RETADDR _ -> (pushretaddr_ind, instr_nb - 1) :: pra_ofs 198 | | _ -> assert false 199 | end; 200 | | _ -> pra_ofs 201 | in 202 | gen_new_code (i + 1) (j + instr_nb) new_pra_ofs (rev_instrs @ acc) 203 | ) 204 | in 205 | let (pra_ofs, new_code) = gen_new_code 0 0 [] [] in 206 | let new_code = Step1.remap_code ptr_map new_code in 207 | List.iter (fun (pushretaddr_ind, ofs) -> 208 | let i = ptr_map.(pushretaddr_ind) in 209 | match new_code.(i) with 210 | | PUSH_RETADDR ptr -> new_code.(i) <- PUSH_RETADDR (ptr - ofs) 211 | | _ -> assert false 212 | ) pra_ofs; 213 | (***) 214 | let remap_getglobals instr_ind bc = 215 | match bc with 216 | | GETGLOBAL n -> new_code.(instr_ind) <- GETGLOBAL data_map.(n) 217 | | _ -> () 218 | in 219 | Array.iteri remap_getglobals new_code; 220 | (***) 221 | new_code 222 | ;; 223 | 224 | let clean_environments code data = 225 | Printexc.record_backtrace true; 226 | let (code, data, nexts) = replace_envaccs code data in 227 | let code = factor_globals code data nexts in 228 | (code, data) 229 | ;; 230 | -------------------------------------------------------------------------------- /src/step2.ml: -------------------------------------------------------------------------------- 1 | (*************************************************************************) 2 | (* *) 3 | (* OCamlClean *) 4 | (* *) 5 | (* Benoit Vaugon *) 6 | (* *) 7 | (* This file is distributed under the terms of the CeCILL license. *) 8 | (* See file ../LICENSE-en. *) 9 | (* *) 10 | (*************************************************************************) 11 | 12 | open OByteLib.Normalised_instr 13 | 14 | let is_removable prim bc = 15 | match bc with 16 | | C_CALL (_, p) -> 17 | Prim.no_side_effect prim.(p) 18 | | POP _ | APPLY _ | PUSHTRAP _ | POPTRAP | RAISE | RERAISE 19 | | RAISE_NOTRACE | OFFSETCLOSURE _ | OFFSETREF _ | CHECK_SIGNALS 20 | | SETGLOBAL _ | SETVECTITEM | SETBYTESCHAR 21 | | BRANCH _ | BRANCHIF _ | BRANCHIFNOT _ 22 | | SWITCH (_, _) | SETFIELD _ | SETFLOATFIELD _ 23 | | COMPBRANCH (_, _, _) | BINAPP (DIV | MOD) | STOP -> 24 | false 25 | | _ -> 26 | true 27 | ;; 28 | 29 | let compute_deps code = 30 | let nb_instr = Array.length code in 31 | let stacks = Array.make nb_instr [||] in 32 | let accus = Array.make nb_instr [] in 33 | let stack_sizes = Array.make nb_instr (-1) in 34 | let use_ind = Array.make nb_instr [] in 35 | let use = Array.make nb_instr [] in 36 | let used_by = Array.make nb_instr 0 in 37 | let in_main = Array.make nb_instr false in 38 | let factor_list = 39 | let fact_table = Array.make nb_instr [] in 40 | fun l -> match l with 41 | | [] -> [] 42 | | (x :: _) -> 43 | let rec f l ls ft x = match ls with 44 | | [] -> ft.(x) <- l :: ft.(x); l 45 | | l' :: rest -> if l = l' then l' else f l rest ft x in 46 | f l fact_table.(x) fact_table x in 47 | let rec pop s n = if n = 0 then s else pop (List.tl s) (pred n) in 48 | let rec f i s a z = 49 | let use_stack n = 50 | if not (List.mem n use_ind.(i)) then use_ind.(i) <- n :: use_ind.(i); 51 | let c = List.nth s n in 52 | if not (List.mem c use.(i)) then ( 53 | use.(i) <- c :: use.(i); 54 | used_by.(c) <- used_by.(c) + 1; 55 | ) 56 | in 57 | let use_accu () = 58 | if not (List.mem a use.(i)) && a <> -1 then ( 59 | use.(i) <- a :: use.(i); 60 | used_by.(a) <- used_by.(a) + 1; 61 | ) 62 | in 63 | let use_stack_top n = 64 | for k = 0 to n - 1 do use_stack k done; 65 | in 66 | let error () = failwith "Step2.compute_deps" in 67 | let test_stack = 68 | if stack_sizes.(i) = -1 then 69 | let sz = List.length s in 70 | let tbl = Array.make sz [] in 71 | let rec f i s = match s with 72 | | [] -> () 73 | | n :: rest -> tbl.(i) <- factor_list [ n ]; f (i + 1) rest in 74 | f 0 s; 75 | stacks.(i) <- tbl; 76 | true 77 | else 78 | let rec f i s tbl b = match s with 79 | | [] -> b 80 | | n :: rest -> 81 | if List.mem n tbl.(i) then f (i + 1) rest tbl b else 82 | (tbl.(i) <- factor_list (n :: tbl.(i)); 83 | f (i + 1) rest tbl true) in 84 | try f 0 s stacks.(i) false with _ -> error () 85 | in 86 | let test_accu = 87 | if a <> -1 && not (List.mem a accus.(i)) then 88 | (accus.(i) <- a :: accus.(i); true) else false 89 | in 90 | let sz = stack_sizes.(i) in 91 | if sz = -1 then stack_sizes.(i) <- z else if sz <> z then error (); 92 | if i < nb_instr && (test_stack || test_accu) then ( 93 | in_main.(i) <- true; 94 | match code.(i) with 95 | | PUSH -> 96 | use_accu (); f (succ i) (i :: s) a (succ z); 97 | | POP n -> 98 | f (succ i) (pop s n) a (z - n); 99 | | ASSIGN n -> 100 | let rec g s k = 101 | if k = 0 then i :: List.tl s else 102 | List.hd s :: g (List.tl s) (pred k) 103 | in 104 | use_accu (); f (succ i) (g s n) i z; 105 | | PUSH_RETADDR _ -> 106 | f (succ i) (i :: i :: i :: s) a (z + 3); 107 | | APPLY n -> 108 | if n > 3 then ( 109 | use_accu (); use_stack_top (n + 3); 110 | f (succ i) (pop s (n + 3)) i (z - n - 3); 111 | ) else ( 112 | use_accu (); use_stack_top n; 113 | f (succ i) (pop s n) i (z - n); 114 | ) 115 | | CLOSURE (n, _) -> 116 | if n > 0 then use_accu (); use_stack_top n; 117 | f (succ i) (pop s (max (n - 1) 0)) i (z - max (n - 1) 0); 118 | | CLOSUREREC (cv, ct) -> 119 | let cf = Array.length ct in 120 | if cv > 0 then use_accu (); use_stack_top cv; 121 | let rec g s k = if k = 0 then s else g (i :: s) (pred k) in 122 | let nb_pop = max (cv - 1) 0 in 123 | f (succ i) (g (pop s nb_pop) cf) i (z - nb_pop + cf); 124 | | MAKEBLOCK (_, n) | MAKEFLOATBLOCK n -> 125 | use_accu (); use_stack_top (n - 1); 126 | f (succ i) (pop s (n - 1)) i (z - n + 1); 127 | | PUSHTRAP ptr -> 128 | f ptr s a z; 129 | f (succ i) (i :: i :: i :: i :: s) a (z + 4); 130 | | POPTRAP -> 131 | f (succ i) (pop s 4) a (z - 4); 132 | | RAISE | RERAISE | RAISE_NOTRACE -> 133 | use_accu (); 134 | | GETMETHOD | GETDYNMET -> 135 | use_accu (); use_stack 0; f (succ i) s i z; 136 | | GETPUBMET _ -> 137 | use_accu (); f (succ i) (i :: s) i (succ z); 138 | | CHECK_SIGNALS -> 139 | f (succ i) s a z; 140 | | OFFSETCLOSURE _ | GETGLOBAL _ 141 | | ATOM _ | CONSTINT _ | ENVACC _ -> 142 | f (succ i) s i z; 143 | | OFFSETREF _ -> 144 | use_accu (); f (succ i) s a z; 145 | | GETFIELD _ | GETFLOATFIELD _ | SETGLOBAL _ 146 | | UNAPP _ -> 147 | use_accu (); f (succ i) s i z; 148 | | ACC n -> 149 | use_stack n; f (succ i) s i z; 150 | | SETVECTITEM | SETBYTESCHAR -> 151 | use_accu (); use_stack 0; use_stack 1; 152 | f (succ i) (pop s 2) i (z - 2); 153 | | BRANCH ptr -> 154 | f ptr s a z; 155 | | SWITCH (iptrs, pptrs) -> 156 | use_accu (); 157 | Array.iter (fun ptr -> f ptr s a z) iptrs; 158 | Array.iter (fun ptr -> f ptr s a z) pptrs; 159 | | C_CALL (n, _) -> 160 | use_accu (); use_stack_top (n - 1); 161 | f (succ i) (pop s (n - 1)) i (z - n + 1); 162 | | BINAPP _ | COMPARE _ 163 | | SETFIELD _ | SETFLOATFIELD _ | GETVECTITEM 164 | | GETBYTESCHAR | GETSTRINGCHAR -> 165 | use_accu (); use_stack 0; f (succ i) (pop s 1) i (z - 1); 166 | | COMPBRANCH (_, _, ptr) | BRANCHIF ptr | BRANCHIFNOT ptr -> 167 | use_accu (); f ptr s a z; f (succ i) s a z; 168 | | RETURN _ | RESTART | GRAB _ | APPTERM (_, _) -> 169 | error () 170 | | STOP -> () 171 | ) 172 | in 173 | f 0 [] (-1) 0; 174 | (accus, stacks, stack_sizes, in_main, use_ind, use, used_by) 175 | ;; 176 | 177 | let compute_cleanables code prim in_main use used_by = 178 | let nb_instr = Array.length code in 179 | let cleanables = Array.make nb_instr false in 180 | let rec f i = 181 | if in_main.(i) && used_by.(i) = 0 && is_removable prim code.(i) then 182 | let ui = use.(i) in 183 | use.(i) <- []; 184 | cleanables.(i) <- true; 185 | List.iter (fun k -> used_by.(k) <- used_by.(k) - 1) ui; 186 | List.iter f ui; 187 | in 188 | for i = 0 to nb_instr - 1 do f i done; 189 | cleanables 190 | ;; 191 | 192 | let compute_blocked code accus stacks in_main use_ind cleanables = 193 | let nb_instr = Array.length accus in 194 | let blocked = Array.make nb_instr false in 195 | let check l = 196 | if List.exists (fun k -> not cleanables.(k)) l then 197 | List.iter (fun k -> blocked.(k) <- true) l 198 | in 199 | for i = 0 to nb_instr - 1 do 200 | if in_main.(i) then ( 201 | check accus.(i); 202 | List.iter 203 | (fun k -> check stacks.(i).(k)) 204 | use_ind.(i); 205 | if not cleanables.(i) then 206 | match code.(i) with 207 | | ASSIGN n -> List.iter (fun k -> blocked.(k) <- true) stacks.(i).(n) 208 | | _ -> () 209 | ) 210 | done; 211 | blocked 212 | ;; 213 | 214 | let clean_code code stacks in_main cleanables blocked = 215 | let nb_instr = Array.length code in 216 | let error () = failwith "Step2.clean_code" in 217 | for i = 0 to nb_instr - 1 do 218 | let compute_new_stack_top_size n = 219 | let rec f l k i r = 220 | if k = 0 then r else 221 | let n = List.hd l.(i) in 222 | f l (pred k) (i + 1) 223 | (if cleanables.(n) && not blocked.(n) then r else r + 1) in 224 | f stacks.(i) n 0 0 225 | in 226 | if in_main.(i) then 227 | if cleanables.(i) then 228 | code.(i) <- 229 | match code.(i) with 230 | | PUSH | PUSH_RETADDR _ | GETPUBMET _ -> 231 | if blocked.(i) then code.(i) else Step1.nop 232 | | CLOSUREREC (cv, ct) -> 233 | let cf = Array.length ct in 234 | let nb_pop = max (cv - 1) 0 - cf in 235 | if nb_pop > 0 then POP (compute_new_stack_top_size nb_pop) 236 | else if nb_pop = 0 || not blocked.(i) then Step1.nop 237 | else code.(i) 238 | | GETMETHOD | GETDYNMET | ENVACC _ | ATOM _ 239 | | GETFIELD _ | GETFLOATFIELD _ | GETGLOBAL _ 240 | | CONSTINT _ | UNAPP _ | ACC _ | ASSIGN _ -> 241 | Step1.nop 242 | | BINAPP _ | COMPARE _ 243 | | GETVECTITEM | GETSTRINGCHAR | GETBYTESCHAR -> 244 | POP (compute_new_stack_top_size 1) 245 | | C_CALL (n, _) | MAKEBLOCK (_, n) | MAKEFLOATBLOCK n -> 246 | POP (compute_new_stack_top_size (n - 1)) 247 | | CLOSURE (n, _) -> 248 | POP (compute_new_stack_top_size (max (n - 1) 0)) 249 | | POP _ | APPLY _ | PUSHTRAP _ | POPTRAP 250 | | RAISE | RERAISE | RAISE_NOTRACE | OFFSETCLOSURE _ 251 | | OFFSETREF _ | CHECK_SIGNALS 252 | | SETGLOBAL _ | SETVECTITEM | SETBYTESCHAR 253 | | BRANCH _ | SWITCH (_, _) | SETFIELD _ | SETFLOATFIELD _ 254 | | COMPBRANCH (_, _, _) | BRANCHIF _ | BRANCHIFNOT _ | STOP 255 | | APPTERM (_, _) | RETURN _ | RESTART | GRAB _ -> 256 | error () 257 | else (* not cleanable *) 258 | match code.(i) with 259 | | ACC n -> code.(i) <- ACC (compute_new_stack_top_size n) 260 | | POP n -> code.(i) <- POP (compute_new_stack_top_size n) 261 | | _ -> () 262 | done; 263 | ;; 264 | 265 | let clean code prim = 266 | let (accus, stacks, _, in_main, use_ind, use, used_by) = compute_deps code in 267 | let cleanables = compute_cleanables code prim in_main use used_by in 268 | let blocked = compute_blocked code accus stacks in_main use_ind cleanables in 269 | clean_code code stacks in_main cleanables blocked; 270 | ;; 271 | --------------------------------------------------------------------------------